{-# LANGUAGE OverloadedStrings #-}
-- | Renders forms to an HTML menu, for the sake of highly-constrained browser engines.
-- Like those dealing with TV remotes.
module Text.HTML.Form.WebApp (renderPage, Form(..), Query) where

import Data.ByteString as BS
import Data.ByteString.Char8 as B8
import Data.Text as Txt
import Data.Text.Encoding as Txt
import Data.List as L
import Data.Maybe (fromMaybe)
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', applyQuery')
import Text.HTML.Form.Validate (isFormValid')
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)

-- | The query string manipulated by this serverside webapp.
type Query = [(ByteString, Maybe ByteString)]
-- | Converts URI path & query to rendered hyper-linked HTML representing menus
-- for selecting values to upload to the server as prescribed by the given form.
-- These values are returned to caller on the Left-branch.
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

-- | Is this input type amongst the date-time family?
isCalType :: Text -> Bool
isCalType = flip L.elem ["date", "datetime-local", "datetime", "month", "time", "week"]
-- | Render an input to the corresponding HTML, or form data to submit.
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 $ \x -> case x of
        "isFormValid" -> toGVal $ formValidate input &&
                isFormValid' (applyQuery' form $ strQuery qs)
        _ -> toGVal ()
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 $ lang form
        "shades" -> toGVal False
        "subfolder" -> toGVal False
        _ -> toGVal ()
renderInput form ix input@Input { inputType = "color" } [c, ""] qs =
    template' "color.html" form ix input qs $ \x -> case x of
        "colours" -> V.list $ L.map colourGVal $ tailwindColours l
        "shades" -> case Txt.unpack c `lookup` tailwindColours l of
            Just shades -> V.list $ L.map shadeGVal shades
            Nothing -> toGVal False
        "subfolder" -> toGVal True
        _ -> toGVal ()
 where l = lang form
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]

-- | Coerce Colour Pallet data into dynamically-typed Ginger data.
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]

-- | Convert Text to UTF8 ByteString data.
utf8 :: Text -> ByteString
utf8 = Txt.encodeUtf8
-- | Convert String to UTF8 ByteString data.
utf8' :: String -> ByteString
utf8' = utf8 . Txt.pack
-- | Set the given key in the query to the given value.
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']
-- | Remove given key from the query.
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'))]
-- | Retrieve the value corresponding to the given key in the query.
get :: Text -> [(ByteString, Maybe ByteString)] -> String
get k' qs
    | Just (Just ret) <- utf8 k' `lookup` qs =
        Txt.unpack $ Txt.decodeUtf8 ret
    | otherwise = ""
-- | Convert the query data to string-pairs, for use in Query submodule.
strQuery :: [(ByteString, Maybe ByteString)] -> [(String, String)]
strQuery qs = [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- qs]

-- | Monadically takes a predicate and a list, and returns the pair of lists
-- of elements which do and do not satisfy the predicate, respectively.
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)