{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
module Internal.Forms(findForm, prefillForm, modifyForm, formAction, clearForm, sendText, typable) where

import Text.XML
import Text.XML.Cursor
import qualified Data.Map as M
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as Txt

import Network.URI (URI(..), parseURIReference, relativeTo, nullURI)
import qualified Network.HTTP.Client.MultipartFormData as HTTP

import Internal (Session, Session'(..))
import Data.Aeson
import GHC.Generics
import Control.Concurrent.MVar

import Data.Maybe
import Data.List

findForm :: Cursor -> HM.HashMap Txt.Text Cursor -> Element
findForm cursor id2els
    | NodeElement el@(Element (Name "form" _ _) _ _) <- node cursor = el
    | NodeElement el <- node cursor, Just el' <- findForm' el id2els = el'
    | (form:_) <- parent cursor = findForm form id2els -- Propagate id2els for the sake of event dispatch.
    | otherwise = Element "fail" M.empty [] -- Tombstone value

findForm' :: Element -> HM.HashMap Txt.Text Cursor -> Maybe Element
findForm' (Element (Name name _ _) attrs _) id2els
    | name == "label", Just for <- "for" `M.lookup` attrs',
            Just input <- for `HM.lookup` id2els = Just $ findForm input id2els
    | Just form <- "form" `M.lookup` attrs', Just cursor <- form `HM.lookup` id2els,
        NodeElement ret <- node cursor = Just ret
    | otherwise = Nothing
  where attrs' = M.mapKeys nameLocalName attrs

prefillForm (Element (Name "form" _ _) attrs children) root = HM.fromListWith (++) (
    (prefillForm' $ map node $ (descendant >=> checkElement isForForm) root) ++
    prefillForm' children)
  where
    isForForm (Element _ attrs' _) | Just id <- "id" `M.lookup` M.mapKeys nameLocalName attrs,
        Just form <- "form" `M.lookup` M.mapKeys nameLocalName attrs' = id == form
    isForForm _ = False
prefillForm _ _ = HM.empty

prefillForm' (NodeElement (Element (Name "input" _ _) attrs _):nodes)
    | Just type_ <- "type" `M.lookup` attrs', Just name <- "name" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs',
            type_ `notElem` ["radio", "checkbox", "reset", "submit", "button"] || "checked" `M.member` attrs' =
        (name, [value]):prefillForm' nodes
  where attrs' = M.mapKeys nameLocalName attrs
prefillForm' (NodeElement (Element (Name "select" _ _) attrs childs):nodes)
    | Just name <- "name" `M.lookup` attrs' =
        case [value | NodeElement (Element _ attrs2 _) <- childs,
                value <- maybeToList $ M.lookup "value" $ M.mapKeys nameLocalName attrs2] of
            [] -> prefillForm' nodes
            values | "multiple" `M.member` attrs' -> (name, values):prefillForm' nodes
            (value:_) -> (name, [value]):prefillForm' nodes
  where attrs' = M.mapKeys nameLocalName attrs
prefillForm' (NodeElement (Element (Name "textarea" _ _) attrs childs):nodes)
    | Just name <- "name" `M.lookup` attrs =
        (name, [Txt.concat [value | NodeContent value <- childs]]):prefillForm' nodes
prefillForm' (_:nodes) = prefillForm' nodes
prefillForm' [] = []

modifyForm :: ([Txt.Text] -> [Txt.Text]) -> Txt.Text -> Cursor -> Session -> IO ()
modifyForm cb name el session = modifyMVar_ session $ \session' -> do
    let form = findForm el $ id2els session'
    let blanked = prefillForm form $ fromDocument $ document session'
    let old = M.findWithDefault blanked form $ forms session'
    let new = HM.insert name (cb $ HM.lookupDefault [] name old) old
    return $ case form of
        Element (Name "form" _ _) _ _ ->
            session' { forms = M.insert form new $ forms session' }
        _ -> session'

serializeForm :: HM.HashMap Txt.Text [Txt.Text] -> Txt.Text
serializeForm = Txt.intercalate "&" . map joinEntry . expandValues . HM.toList
    where
        expandValues ((a, (b:bs)):rest) = (a, b):expandValues ((a, bs):rest)
        expandValues ((a, []):rest) = expandValues rest
        expandValues [] = []
        joinEntry (key, value) = key `Txt.append` Txt.cons '=' value

formAction :: Cursor -> Session -> IO (URI, Txt.Text, Txt.Text)
formAction el session = withMVar session $ \session' -> do
    let form = findForm el $ id2els session'
    let blanked = prefillForm form $ fromDocument $ document session'
    let inputs = M.findWithDefault blanked form $ forms session'
    let query = serializeForm inputs

    let fAttrs' = M.mapKeys nameLocalName $ elementAttributes form
    let iAttrs' = case node el of {
        NodeElement (Element _ attrs _) -> M.mapKeys nameLocalName attrs;
        _ -> M.empty
    }
    let action = case ("formaction" `M.lookup` iAttrs', "action" `M.lookup` fAttrs') of {
        (Just action, _) -> parseURIReference $ Txt.unpack action;
        (_, Just action) -> parseURIReference $ Txt.unpack action;
        (_, _) -> Nothing
    }
    let method = case ("formmethod" `M.lookup` iAttrs', "action" `M.lookup` fAttrs') of {
        (Just method, _) -> method;
        (_, Just method) -> method;
        (_, _) -> "GET"
    }

    return (fromMaybe nullURI action `relativeTo` currentURL session', query, method)

clearForm session el = modifyMVar_ session $ \session' -> do
    let form = findForm el $ id2els session'
    return $ case form of
        Element (Name "form" _ _) _ _ ->
            session' { forms = M.delete form $ forms session' }
        _ -> session'

data SendText = SendText { text :: Txt.Text } deriving Generic
instance FromJSON SendText
instance ToJSON SendText

sendText input cursor session
    | NodeElement el <- node cursor = sendText' input el cursor session
    | otherwise = return ()
sendText' input (Element (Name "input" _ _) attrs _) cursor session
--    | Just "file" <- "type" `M.lookup` attrs' = return ()-- TODO define a place in HURL to store files to be uploaded...
    | Just "radio" <- "type" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs',
        Just name <- "name" `M.lookup` attrs' = modifyForm (const [value]) name cursor session
    | Just "checkbox" <- "type" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs',
        Just name <- "name" `M.lookup` attrs' = modifyForm (toggleOption value) name cursor session
    | Just name <- "name" `M.lookup` attrs' = modifyForm (const [text input]) name cursor session
    | otherwise = return ()
  where
    attrs' = M.mapKeys nameLocalName attrs
    toggleOption value old | value `elem` old = delete value old
        | otherwise = value:old
sendText' input (Element (Name "select" _ _) attrs childs) cursor session
    | Just name <- "name" `M.lookup` attrs', "multiple" `M.member` attrs' =
        let value = mapMaybe findOption $ Txt.lines $ text input
        in modifyForm (const value) name cursor session
    | Just name <- "name" `M.lookup` attrs', Just value <- findOption $ text input =
        modifyForm (const [value]) name cursor session
    | otherwise = return ()
  where
    attrs' = M.mapKeys nameLocalName attrs
    findOption prefix = (M.lookup "value" . M.mapKeys nameLocalName . elementAttributes) =<<
        find (Txt.isPrefixOf prefix . innerText) [
            el | NodeElement el@(Element (Name "option" _ _) _ _) <- childs]
    innerText (Element _ _ childs) = Txt.concat [txt | NodeContent txt <- childs]
sendText' input (Element (Name "textarea" _ _) attrs _) cursor session
    | Just name <- "name" `M.lookup` attrs' = modifyForm (const [text input]) name cursor session
    | otherwise = return ()
  where attrs' = M.mapKeys nameLocalName attrs

typable (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"]