{-# LANGUAGE OverloadedStrings #-}
module Internal.Forms(findForm, prefillForm, modifyForm, formAction) 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 Internal (Session, Session'(..))
import Network.URI (URI(..), parseURIReference, relativeTo, nullURI)

import Data.Maybe
import Control.Concurrent.MVar

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)