{-# 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.Ginger.GVal as V (GVal(..), toGVal, orderedDict, (~>))
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
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
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 [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)