{-# 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.HTML.Form.WebApp.Ginger.TZ (tzdata, continents)

import Text.Ginger.GVal as V (GVal(..), ToGVal(..), orderedDict, (~>), fromFunction, list)
import Text.Ginger.Html (html)
import Data.Hourglass (Elapsed(..), Seconds(..), timeGetElapsed, localTimeToGlobal)
import Text.HTML.Form.Colours (tailwindColours)

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

isCalType :: Text -> Bool
isCalType = flip L.elem ["date", "datetime-local", "datetime", "month", "time", "week"]
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 { inputType = ty, inputName = name } ["year", p] qs
    | isCalType ty,
      Just t <- modifyTime' (Txt.pack $ "year/" ++ Txt.unpack p) $ get name qs = do
        t' <- timeParseOrNow t
        template' "cal/year-numpad.html" form ix input (set name (Txt.pack t) qs) $
            \prop -> case prop of
                "T" -> timeData t'
                _ -> toGVal ()
renderInput form ix input@Input { inputType = ty, inputName = name } ["zone", p] qs
    | isCalType ty = do
        t <- timeParseOrNow $ get name qs
        let Elapsed (Seconds t') = timeGetElapsed $ localTimeToGlobal t
        template' "cal/timezone.html" form ix input qs $ \prop -> case prop of
            "T" -> timeData t
            "zones" -> tzdata t' $ unEscapeString $ Txt.unpack p
            "continents" -> continents
            _ -> toGVal ()
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 = ty, inputName = n } [op] qs
    | "week" <- ty, "+date" <- op = renderInput form ix input ["+date7"] qs
    | "week" <- ty, "-date" <- op = renderInput form ix input ["-date7"] qs
    | isCalType ty, 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 ()
    | isCalType ty = return Nothing
renderInput f ix input@Input { inputType = ty, inputName = n } [] qs | isCalType ty = do
    v' <- timeParseOrNow $ get n qs
    template' "gregorian.html" f 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@Input { inputType = "color" } [] qs =
    template' "color.html" form ix input qs $ \x -> case x of
        "colours" -> V.list $ L.map colourGVal tailwindColours
        "shades" -> toGVal False
        "subfolder" -> toGVal False
        _ -> toGVal ()
renderInput form ix input@Input { inputType = "color", inputName = n } [c, ""] qs =
    template' "color.html" form ix input qs $ \x -> case x of
        "colours" -> V.list $ L.map colourGVal tailwindColours
        "shades" -> case Txt.unpack c `lookup` tailwindColours of
            Just shades -> V.list $ L.map shadeGVal shades
            Nothing -> toGVal False
        "subfolder" -> toGVal True
        _ -> 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]

colourGVal :: (ToGVal m a1, ToGVal m b, Eq a2, Num a2) => (a1, [(a2, b)]) -> GVal m
colourGVal (key, hues) = orderedDict ["label"~>key, "value"~>lookup 500 hues]
shadeGVal :: (ToGVal m a1, ToGVal m a2) => (a1, a2) -> GVal m
shadeGVal (key, val) = orderedDict ["label"~>key, "value"~>val]

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)