{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}

module Handler.Utils.Form
  ( module Handler.Utils.Form
  , module Utils.Form
  ) where

import Utils.Form

import Handler.Utils.Form.Types
import Handler.Utils.Templates

import Handler.Utils.DateTime
import qualified Data.Time as Time

import Import
import qualified Data.Char as Char
import Data.String (IsString(..))

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import qualified Data.Foldable as Foldable

-- import Yesod.Core
import qualified Data.Text as T
-- import Yesod.Form.Types
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3

import Web.PathPieces (showToPathPiece, readFromPathPiece)

import Handler.Utils.Zip
import qualified Data.Conduit.List as C

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Map (Map)
import qualified Data.Map as Map

import Control.Monad.Writer.Class

import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)

----------------------------
-- Buttons (new version ) --
----------------------------

data BtnDelete = BtnDelete | BtnAbort
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece BtnDelete where    -- for displaying the button only, not really for paths
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

instance Button UniWorX BtnDelete where
  label BtnDelete = [whamlet|_{MsgBtnDelete}|]
  label BtnAbort  = [whamlet|_{MsgBtnAbort}|]

  cssClass BtnDelete = BCDanger
  cssClass BtnAbort  = BCDefault

data RegisterButton = BtnRegister  | BtnDeregister
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece RegisterButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

instance Button UniWorX RegisterButton where
  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]

  cssClass BtnRegister   = BCPrimary
  cssClass BtnDeregister = BCDanger

data AdminHijackUserButton = BtnHijack
  deriving (Enum, Eq, Ord, Bounded, Read, Show)

instance PathPiece AdminHijackUserButton where
  toPathPiece   = showToPathPiece
  fromPathPiece = readFromPathPiece

instance Button UniWorX AdminHijackUserButton where
  label BtnHijack = [whamlet|_{MsgBtnHijack}|]

  cssClass BtnHijack = BCDefault


-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
-- data LinkButton = LinkButton (Route UniWorX)
--   deriving (Enum, Eq, Ord, Bounded, Read, Show)
--
-- instance PathPiece LinkButton where
--     LinkButton route = ???

linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
--   [whamlet|
--     <form method=post action=@{url}>
--       <input type="hidden" name="_formid" value="identify-linkButton">
--       <button .btn .#{bcc2txt cls} type=submit value="Link to @{url}">^{lbl}
--   |]
  --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>

simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]


    {-
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
combinedButtonField btns inner csrf = do
    buttonIdent <- newFormIdent
    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
    (innerRes,innerWdgt) <- inner
    let widget = do
          [whamlet|
            #{csrf}
            ^{innerWdgt}
            <div .btn-group>
              $forall bView <- btnViews
                ^{fvInput bView}
          |]
    let result = case (accResult result, innerRes) of
                    (FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
                    _ -> FormFailure ["Something went wrong"] -- TODO
    return (result,widget)
  where
    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
    accResult = Foldable.foldr accResult' FormMissing

    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
    accResult' (FormSuccess (Just x)) _ = FormSuccess x
    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
    accResult' (FormSuccess Nothing) x = x
    accResult' FormMissing _ = FormMissing
    accResult' (FormFailure errs) _ = FormFailure errs
    -}

-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
buttonForm :: (Button UniWorX a) => Form a
buttonForm csrf = do
    buttonIdent <- newFormIdent
    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
    let widget = do
          [whamlet|
            #{csrf}
            $forall bView <- btnViews
              ^{fvInput bView}
          |]
    return (accResult results,widget)
  where
    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
    accResult = Foldable.foldr accResult' FormMissing

    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
    accResult' (FormSuccess (Just x)) _ = FormSuccess x
    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
    accResult' (FormSuccess Nothing) x = x
    accResult' FormMissing _ = FormMissing
    accResult' (FormFailure errs) _ = FormFailure errs



------------
-- Fields --
------------

ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
ciField = convertField CI.mk CI.original

natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField

natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") $ intField

natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField

posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") $ intField

minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField

pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
        |]
    fieldParse = parseHelper $ \t -> do
      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
      return . fromRational $ round (sci * 100) % 100

--termField:   see Utils.Term

schoolField :: Field Handler SchoolId
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName

schoolFieldEnt :: Field Handler (Entity School)
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName

schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolId <-. userSchools] [Asc SchoolName] schoolName

zipFileField :: Bool -- ^ Unpack zips?
             -> Field Handler (Source Handler File)
zipFileField doUnpack = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse _ files
      | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
      | null files   = return $ Right Nothing
      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
    fieldView fieldId fieldName attrs _ req = do
      [whamlet|
        $newline never
        <input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
      |]

multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
multiFileField permittedFiles' = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse vals files
      | null files
      , null vals = return $ Right Nothing
      | otherwise = return . Right . Just $ do
          pVals <- lift permittedFiles'
          let
            decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
            decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt 
          yieldMany vals
            .| C.filter (/= unpackZips)
            .| C.map fromPathPiece .| C.catMaybes
            .| C.mapMaybeM decrypt'
            .| C.filter (`elem` pVals)
            .| C.map Left
          let
            handleFile :: FileInfo -> Source Handler File
            handleFile
              | doUnpack  = sourceFiles
              | otherwise = yieldM . acceptFile
          mapM_ handleFile files .| C.map Right
      where
        doUnpack = unpackZips `elem` vals
    fieldView fieldId fieldName attrs val req = do
      pVals <- handlerToWidget permittedFiles'
      sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
      let
        toFUI (E.Value fuiId', E.Value fuiTitle) = do
          fuiId <- encrypt fuiId'
          fuiHtmlId <- newIdent
          let fuiChecked
                | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
                | otherwise = True
          return FileUploadInfo{..}     
      fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
          E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
          E.orderBy [E.asc $ file E.^. FileTitle]
          return (file E.^. FileId, file E.^. FileTitle)
      $(widgetFile "multiFileField")
    unpackZips :: Text
    unpackZips = "unpack-zip"
    takeLefts :: Monad m => ConduitM (Either b a) b m ()
    takeLefts = awaitForever $ \case
      Right _ -> return ()
      Left  r -> yield r

sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq d Nothing =
  -- TODO, offer options to choose between Normal/Bonus/Pass
  (Normal . toPoints) <$> areq (natField "Punkte") d Nothing
sheetTypeAFormReq d (Just (Normal p)) =
  -- TODO, offer options to choose between Normal/Bonus/Pass
  (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded


sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
sheetGroupAFormReq d _other = -- TODO
  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)

{-
dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
dayTimeField fs mutc = do
    let (mbDay,mbTime) = case mutcs of
          Nothing    -> return (Nothing,Nothing)
          (Just utc) ->

    (dayResult, dayView) <- mreq dayField fs

    (result, view) <- (,) <$> dayField <*> timeField
  where
    (mbDay,mbTime)
      | (Just utc) <- mutc =
          let lt = utcToLocalTime ??? utcs
          in  (Just $ localDay lt, Just $ localTimeOfDay lt)
      | otherwise = (Nothing,Nothing)
-}


utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
-- Browser returns LocalTime
utcTimeField = Field
    { fieldParse = parseHelperGen $ readTime
    , fieldView = \theId name attrs val isReq -> do
        val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
        [whamlet|
          $newline never
          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
        |]
    , fieldEnctype = UrlEncoded
    }
  where
    fieldTimeFormat :: String
    --fieldTimeFormat = "%e.%m.%y %k:%M"
    fieldTimeFormat = "%Y-%m-%dT%H:%M"
    
    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any 
    readTime :: Text -> Either UniWorXMessage UTCTime
    readTime t =
      case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
        (Just (LTUUnique time _))     -> Right time
        (Just (LTUNone _ _))          -> Left MsgIllDefinedUTCTime
        (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
        Nothing -> Left MsgInvalidDateTimeFormat


fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap

fsb :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors

optionsPersistCryptoId :: forall site backend a msg.
                          ( YesodPersist site
                          , PersistQueryRead backend
                          , HasCryptoUUID (Key a) (HandlerT site IO)
                          , RenderMessage site msg
                          , YesodPersistBackend site ~ backend
                          , PersistRecordBackend a backend
                          )
                       => [Filter a]
                       -> [SelectOpt a]
                       -> (a -> msg)
                       -> HandlerT site IO (OptionList (Entity a))
optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
  mr <- getMessageRender
  pairs <- runDB $ selectList filts ords
  cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
  return $ map (\(cId, e@(Entity key value)) -> Option
                 { optionDisplay = mr (toDisplay value)
                 , optionInternalValue = e
                 , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                 }) cPairs

optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a )
              => (a -> msg) -> m (OptionList a)
optionsFinite toMsg = do
  mr <- getMessageRender
  let
    mkOption a = Option
      { optionDisplay       = mr $ toMsg a
      , optionInternalValue = a
      , optionExternalValue = toPathPiece a
      }
  return . mkOptionList $ mkOption <$> universeF

mforced :: (site ~ HandlerSite m, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
mforced Field{..} FieldSettings{..} val = do
  tell fieldEnctype
  name <- maybe newFormIdent return fsName
  theId <- lift $ maybe newIdent return fsId
  mr <- getMessageRender
  let fsAttrs' = fsAttrs <> [("disabled", "")]
  return ( FormSuccess val
         , FieldView
           { fvLabel = toHtml $ mr fsLabel
           , fvTooltip = toHtml <$> fmap mr fsTooltip
           , fvId = theId
           , fvInput = fieldView theId name fsAttrs' (Right val) False
           , fvErrors = Nothing
           , fvRequired = False
           }
         )

aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> AForm m a
aforced field settings val = formToAForm $ second pure <$> mforced field settings val

multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts = do
  mr <- getMessageRender
  let
    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
  results <- sequence acts
  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
      actionResults = Map.map fst results
  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))