{-# LANGUAGE OverloadedStrings #-}
module Text.HTML.Form.WebApp (renderPage, Form(..)) where

import Data.ByteString as BS
import Data.Text as Txt
import Data.Text.Encoding as Txt
import Data.List as L
import Text.Read (readMaybe)
import Network.URI (unEscapeString)
import System.IO (readFile')
import System.FilePath ((</>), normalise)
import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist,
        doesDirectoryExist, listDirectory, getHomeDirectory)

import Text.HTML.Form (Form(..), Input(..))
import Text.HTML.Form.WebApp.Ginger (template, template', resolveSource, list')
import Text.HTML.Form.Query (renderQueryString, renderQuery')
import Text.HTML.Form.WebApp.Ginger.Hourglass (timeData, modifyTime', timeParseOrNow,
        gSeqTo, gPad2)

import Text.Ginger.GVal as V (GVal(..), toGVal, orderedDict, (~>), fromFunction)
import Text.Ginger.Html (html)

type Query = [(ByteString, Maybe ByteString)]
renderPage :: Form -> [Text] -> Query -> IO (Maybe (Either Query Text))
renderPage form (n:path) query
    | Just ix <- readMaybe $ Txt.unpack n, ix < Prelude.length (inputs form) =
        renderInput form ix (inputs form !! ix) path query
renderPage form [] _ = return $ Just $ Right $ Txt.concat [
    "<a href='/0/?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
renderPage _ _ _ = return Nothing

renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
    IO (Maybe (Either Query Text))
renderInput form ix input [""] qs = renderInput form ix input [] qs
renderInput form ix input@Input { multiple = True } [p] qs
    | '=':v' <- Txt.unpack p,
            (utf8 $ inputName input, Just $ utf8' v') `Prelude.elem` qs =
        renderInput form ix input [] $
            unset (inputName input) (Txt.pack $ unEscapeString v') qs
    | '=':v' <- Txt.unpack p = renderInput form ix input [] $
        (utf8 $ inputName input, Just $ utf8' $ unEscapeString v'):qs
renderInput form ix input [p] qs
    | '=':v' <- Txt.unpack p = renderInput form ix input [] $
        set (inputName input) (Txt.pack $ unEscapeString v') qs
    | ':':v' <- Txt.unpack p = renderInput form ix input [] $
        set (inputName input)
            (Txt.pack (get (inputName input) qs ++ v')) qs
    | "-" <- Txt.unpack p, v'@(_:_) <- get (inputName input) qs =
        renderInput form ix input [] $ set (inputName input)
            (Txt.pack $ Prelude.init v') qs
    | "-" <- Txt.unpack p = renderInput form ix input [] qs
    | '+':x' <- Txt.unpack p, Just x <- readMaybe x' :: Maybe Double,
            Just y <- readMaybe $ get (inputName input) qs =
        renderInput form ix input [] $
            set (inputName input) (Txt.pack $ show $ x + y) qs
    | '+':x' <- Txt.unpack p, Just _ <- readMaybe x' :: Maybe Double =
        renderInput form ix input [] $ set (inputName input) (Txt.pack x') qs
renderInput form ix input [x, p] qs
    | '=':v' <- Txt.unpack p = renderInput form ix input [x] $
        set (inputName input) (Txt.pack $ unEscapeString v') qs
    | ':':v' <- Txt.unpack p = renderInput form ix input [x] $
        set (inputName input)
            (Txt.pack (get (inputName input) qs ++ v')) qs
    | "-" <- Txt.unpack p, v'@(_:_) <- get (inputName input) qs =
        renderInput form ix input [x] $ set (inputName input)
            (Txt.pack $ Prelude.init v') qs
    | "-" <- Txt.unpack p = renderInput form ix input [x] qs
    | '+':z' <- Txt.unpack p, Just z <- readMaybe z' :: Maybe Double,
            Just y <- readMaybe $ get (inputName input) qs =
        renderInput form ix input [x] $
            set (inputName input) (Txt.pack $ show $ z + y) qs
    | '+':x' <- Txt.unpack p, Just _ <- readMaybe x' :: Maybe Double =
        renderInput form ix input [x] $ set (inputName input) (Txt.pack x') qs
renderInput form ix input@Input {inputType="checkbox", inputName=k', value=v'} [] qs
    | (utf8 k', Just $ utf8 v') `Prelude.elem` qs =
        template "checkbox.html" form ix input $ unset k' v' qs
    | v' == "", (utf8 k', Nothing) `Prelude.elem` qs =
        template "checkbox.html" form ix input [
            q | q@(k, v) <- qs, not (k == utf8 k' && v == Nothing)]
    | otherwise =
        template "checkbox.html" form ix input $ (utf8 k', Just $ utf8 v'):qs
renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] qs =
    template "checkbox.html" form ix input $ set k' v' qs
renderInput form ix input@Input { inputType="<select>" } [] qs =
    template "select.html" form ix input qs
renderInput form ix input@Input { inputType="submit" } [] qs =
    template "submit.html" form ix input qs
renderInput _ _ input@Input { inputType="submit" } ["_"] qs =
    return $ Just $ Left $ set (inputName input) (value input) qs
renderInput form ix input@Input { inputType="image" } [] qs =
    template "image-button.html" form ix input qs
renderInput _ _ input@Input { inputType="image" } ["_"] qs =
    return $ Just $ Left $ set (inputName input) (value input) qs
renderInput form ix input@Input { inputType="reset" } [] qs =
    template "reset.html" form ix input qs
renderInput form ix input@Input { inputType="reset" } ["_"] _ =
    template "reset.html" form ix input
        [(utf8' k, Just $ utf8' v) | (k, v) <- renderQuery' form]
renderInput form ix input@Input { inputType="file" } path qs = do
    home <- getHomeDirectory
    let filepath = normalise $ L.foldl (</>) home $ L.map Txt.unpack path
    subfiles <- listDirectory filepath
    (dirs, files) <- partitionM (doesDirectoryExist' filepath) subfiles
    template' "files.html" form ix input qs $ \x -> case x of
        "path" -> (list'$L.map buildBreadcrumb$L.inits$L.map Txt.unpack path) {
            asText = Txt.pack filepath,
            asHtml = html $ Txt.pack filepath
          }
        "files" -> toGVal files
        "dirs" -> toGVal dirs
        _ -> toGVal ()
  where
    buildBreadcrumb :: [String] -> GVal m
    buildBreadcrumb [] = toGVal False
    buildBreadcrumb path' = orderedDict [
        "name" ~> L.last path',
        "link" ~> ('/':show ix ++ '/':L.intercalate "/" path')
      ]
    doesDirectoryExist' parent file = doesDirectoryExist $ parent </> file
renderInput form ix input@Input { inputType = "tel" } [] qs =
    template "tel.html" form ix input qs
renderInput form ix input@Input { inputType = "number" } [] qs =
    template "number.html" form ix input qs
renderInput form ix input@Input { inputType = "range" } [] qs =
    template "number.html" form ix input qs
renderInput form ix input@Input { inputType = "date", inputName = n } [op] qs
    | Just v <- modifyTime' op $ get n qs = do
        -- TODO: Support other calendars
        v' <- timeParseOrNow v
        template' "gregorian.html" form ix input (set n (Txt.pack v) qs) $
            \x -> case x of
                "T" -> timeData v'
                "seqTo" -> fromFunction $ return . gSeqTo
                "pad2" -> fromFunction $ return . gPad2
                _ -> toGVal ()
    | otherwise = return Nothing
renderInput form ix input@Input { inputType = "date", inputName = n } [] qs = do
    v' <- timeParseOrNow $ get n qs
    template' "gregorian.html" form ix input qs $ \x -> case x of -- TODO: Ditto
        "T" -> timeData v'
        "seqTo" -> fromFunction $ return . gSeqTo
        "pad2" -> fromFunction $ return . gPad2
        _ -> toGVal ()
renderInput form ix input [keyboard] qs =
    renderInput form ix input [keyboard, ""] qs
renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path =
    template path form ix input qs
  where path = "keyboards/" ++ Txt.unpack keyboard ++ ".html"
renderInput form ix input [keyboard, ""] qs = do
    configpath <- getXdgDirectory XdgConfig "bureaucromancy"
    exists <- doesFileExist $ configpath </> "keyboard"
    namespace <- if exists then readFile' $ configpath </> "keyboard"
        else return "latin1"
    let path = "keyboards/" ++ namespace ++ "/" ++ Txt.unpack keyboard ++ ".html"
    let path2 = "keyboards/" ++ namespace ++ ".html"
    let keyboard'
            | Just (Just _) <- resolveSource path = path
            | Just (Just _) <- resolveSource path2 = path2
            | otherwise = "keyboards/latin1.html"
    template keyboard' form ix input qs
renderInput form ix input [] qs = do
    path <- getXdgDirectory XdgConfig "bureaucromancy"
    exists <- doesFileExist $ path </> "keyboard"
    keyboard <- if exists then readFile' $ path </> "keyboard"
        else return "latin1"
    let keyboard'
            | Just (Just _) <- resolveSource ("keyboards/" ++ keyboard ++ ".html")
                = keyboard
            | otherwise = "latin1"
    template ("keyboards/" ++ keyboard' ++ ".html") form ix input qs
renderInput _ _ input _ _ =
    return $ Just $ Right $ Txt.concat ["Unknown input type: ", inputType input]

utf8 :: Text -> ByteString
utf8 = Txt.encodeUtf8
utf8' :: String -> ByteString
utf8' = utf8 . Txt.pack
set :: Text -> Text -> [(ByteString, Maybe ByteString)]
    -> [(ByteString, Maybe ByteString)]
set "" _ qs = qs -- Mostly for buttons!
set k' v' qs = (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k']
unset :: Text -> Text -> [(ByteString, Maybe ByteString)]
    -> [(ByteString, Maybe ByteString)]
unset k' v' qs = [q | q@(k, v) <- qs, not (k == utf8 k' && v == Just (utf8 v'))]
get :: Text -> [(ByteString, Maybe ByteString)] -> String
get k' qs
    | Just (Just ret) <- utf8 k' `lookup` qs =
        Txt.unpack $ Txt.decodeUtf8 ret
    | otherwise = ""

partitionM :: Monad f => (a -> f Bool) -> [a] -> f ([a], [a])
partitionM _ [] = pure ([], [])
partitionM f (x:xs) = do
    res <- f x
    (as,bs) <- partitionM f xs
    pure ([x | res]++as, [x | not res]++bs)