module Handler.Term
  ( getTermShowR
  , getTermEditR, postTermEditR
  , getTermEditExistR, postTermEditExistR
  ) where

import Import

import Utils.Course (mayViewCourse)

import Handler.Utils

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

import qualified Database.Esqueleto.Legacy as E

import qualified Data.Set as Set

import qualified Control.Monad.State.Class as State

import Data.Time.Calendar.WeekDate


data TermDay
  = TermDayStart | TermDayEnd
  | TermDayLectureStart | TermDayLectureEnd
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)

guessDay :: TermIdentifier
         -> TermDay
         -> Day
guessDay TermIdentifier{ year, season = Winter } TermDayStart
  = fromGregorian year 10 1
guessDay TermIdentifier{ year, season = Winter } TermDayEnd
  = fromGregorian (succ year) 3 31
guessDay TermIdentifier{ year, season = Summer } TermDayStart
  = fromGregorian year 4 1
guessDay TermIdentifier{ year, season = Summer } TermDayEnd
  = fromGregorian year 9 30
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart
  = fromWeekDate year (wWeekStart + 2) 1
  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd
  = fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5
  where longYear = is _Just $ fromWeekDateValid year 53 1
        (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart
  = fromWeekDate year (wWeekStart + 2) 1
  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
  = fromWeekDate year (wWeekStart + 17) 5
  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart


validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
             => FormValidator TermForm m ()
validateTerm = do
  TermForm{..} <- State.get
  guardValidation MsgTermStartMustMatchName $ tfStart `withinTerm` tfName
  guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
  guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
  guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
  guardValidation MsgTermEndMustBeAfterLectureEnd $ tfEnd >= tfLectureEnd


getTermShowR :: Handler Html
getTermShowR = do
  muid <- maybeAuthId
  now <- liftIO getCurrentTime
  ata <- getSessionActiveAuthTags
  table <- runDB $
    let termDBTable = DBTable{..}
          where dbtSQLQuery term = return (term, courseCount, isActive)
                  where courseCount = E.subSelectCount . E.from $ \(course `E.LeftOuterJoin` allocation) -> do
                          E.on . E.exists . E.from $ \allocationCourse ->
                            E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
                                 E.&&. E.just (allocationCourse E.^. AllocationCourseAllocation) E.==. allocation E.?. AllocationId
                          E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
                            E.&&. mayViewCourse muid ata now course (allocation E.?. AllocationId)
                        isActive = termIsActiveE (E.val now) (E.val muid) (term E.^. TermId)
                dbtRowKey = (E.^. TermId)
                dbtProj = dbrOutput <$> dbtProjId
                dbtColonnade = widgetColonnade $ mconcat
                  [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _, _)
                      -> cell $ do
                           mayEdit <- hasWriteAccessTo $ TermEditExistR tid
                           [whamlet|
                             $newline never
                             <a href=@{TermCourseListR tid}>
                               #{toPathPiece tid}
                             $if mayEdit
                               &nbsp;
                               <a href=@{TermEditExistR tid}>
                                 #{iconMenuAdmin}
                           |]
                  , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_,_)
                      -> cell $ formatTime SelFormatDate termLectureStart >>= toWidget
                  , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_,_)
                      -> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
                  , sortable Nothing (i18nCell MsgTermActive) $ \(_, _, E.Value isActive)
                      -> tickmarkCell isActive
                  , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses, _)
                      -> cell [whamlet|_{MsgNumCourses numCourses}|]
                  , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_, _)
                      -> cell $ formatTime SelFormatDate termStart >>= toWidget
                  , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_, _)
                      -> cell $ formatTime SelFormatDate termEnd >>= toWidget
                  , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _)
                      -> cell $ do
                           let termHolidays' = groupHolidays termHolidays
                           [whamlet|
                             $newline never
                             <ul .list--inline .list--comma-separated>
                               $forall holiday <- termHolidays'
                                 $case holiday
                                   $of Left singleHoliday
                                     <li>^{formatTimeW SelFormatDate singleHoliday}
                                   $of Right (startD, endD)
                                     <li>
                                       ^{formatTimeW SelFormatDate startD}
                                       –
                                       ^{formatTimeW SelFormatDate endD}
                           |]
                  ]
                dbtSorting = Map.fromList
                  [ ( "start"
                    , SortColumn $ \term -> term E.^. TermStart
                    )
                  , ( "end"
                    , SortColumn $ \term -> term E.^. TermEnd
                    )
                  , ( "lecture-start"
                    , SortColumn $ \term -> term E.^. TermLectureStart
                    )
                  , ( "lecture-end"
                    , SortColumn $ \term -> term E.^. TermLectureEnd
                    )
                  , ( "term-id"
                    , SortColumn $ \term -> term E.^. TermId
                    )
                  ]
                dbtFilter = Map.fromList
                  [ ( "active"
                    , FilterColumn $ \term -> termIsActiveE (E.val now) (E.val muid) (term E.^. TermId) :: E.SqlExpr (E.Value Bool)
                    )
                  , ( "course"
                    , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
                        []   -> E.val True :: E.SqlExpr (E.Value Bool)
                        cshs -> E.exists . E.from $ \course ->
                          E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
                               E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
                    )
                  ]
                dbtFilterUI = mempty
                dbtStyle = def
                dbtParams = def
                dbtIdent = "terms" :: Text
                dbtCsvEncode = noCsvEncode
                dbtCsvDecode = Nothing
                dbtExtraReps = []
        termDBTableValidator = def & defaultSorting [SortDescBy "term-id"]
    in dbTableWidget' termDBTableValidator termDBTable
  defaultLayout $ do
    setTitleI MsgTermsHeading
    $(widgetFile "terms")

getTermEditR, postTermEditR :: Handler Html
getTermEditR = postTermEditR
postTermEditR = do
  mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
  let template = case mbLastTerm of
        Nothing -> mempty
        (Just Entity{ entityVal=Term{..}})
          -> let ntid = succ termName
             in mempty
                  { tftName  = Just   ntid
                  , tftStart = Just $ guessDay ntid TermDayStart
                  , tftEnd   = Just $ guessDay ntid TermDayEnd
                  , tftLectureStart = Just $ guessDay ntid TermDayLectureStart
                  , tftLectureEnd   = Just $ guessDay ntid TermDayLectureEnd
                  }
  termEditHandler Nothing template

getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
getTermEditExistR = postTermEditExistR
postTermEditExistR tid = do
  (term, active) <- runDB $ do
    term <- get tid
    active <- selectList [ TermActiveTerm ==. tid ] []
    return (term, map entityVal active)
  termEditHandler (Just tid) $ termToTemplate term (map termActiveToForm active)


termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
termEditHandler mtid template = do
    eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid template
    case result of
      (FormSuccess TermForm{..}) -> exceptT (addMessageI Error) return $ do
          let tid = TermKey tfName
          hoist runDB $ do
            let term = Term
                  { termName = tfName
                  , termStart = tfStart
                  , termEnd = tfEnd
                  , termHolidays = tfHolidays
                  , termLectureStart = tfLectureStart
                  , termLectureEnd = tfLectureEnd
                  }
            case mtid of
              Just oTId | tid == oTId ->
                lift $ replace tid term
              _other -> do
                whenM (lift $ exists [TermName ==. tfName]) $
                  throwE MsgTermExists
                lift $ insertKey tid term

            lift $ deleteWhere [TermActiveTerm ==. tid]
            forM_ tfActive $ \TermActiveForm{..} ->
              lift $ insert_ TermActive
                { termActiveTerm = tid
                , termActiveFrom = tafFrom
                , termActiveTo = tafTo
                , termActiveFor = tafFor
                }
            lift . audit $ TransactionTermEdit tid
          addMessageI Success $ MsgTermEdited tid
          redirect TermShowR
      FormMissing     -> return ()
      (FormFailure _) -> addMessageI Warning MsgInvalidInput
    defaultLayout $ do
      setTitleI MsgTermEditHeading
      wrapForm formWidget def
        { formAction = Just $ SomeRoute eHandler
        , formEncoding = formEnctype
        }

data TermFormTemplate = TermFormTemplate
      { tftName         :: Maybe TermIdentifier
      , tftStart        :: Maybe Day
      , tftEnd          :: Maybe Day
      , tftHolidays     :: Maybe [Day]
      , tftLectureStart :: Maybe Day
      , tftLectureEnd   :: Maybe Day
      , tftActive       :: Maybe [TermActiveForm]
      }

-- | TermFormTemplates form a pointwise-left biased Semigroup
instance Semigroup TermFormTemplate where
  l <> r = TermFormTemplate
    { tftName         = tftName         l <|> tftName         r
    , tftStart        = tftStart        l <|> tftStart        r
    , tftEnd          = tftEnd          l <|> tftEnd          r
    , tftHolidays     = tftHolidays     l <|> tftHolidays     r
    , tftLectureStart = tftLectureStart l <|> tftLectureStart r
    , tftLectureEnd   = tftLectureEnd   l <|> tftLectureEnd   r
    , tftActive       = tftActive       l <|> tftActive       r
    }

instance Monoid TermFormTemplate where
  mappend = (<>)
  mempty  = TermFormTemplate
    { tftName         = Nothing
    , tftStart        = Nothing
    , tftEnd          = Nothing
    , tftHolidays     = Nothing
    , tftLectureStart = Nothing
    , tftLectureEnd   = Nothing
    , tftActive       = Nothing
    }

termToTemplate :: Maybe Term -> [TermActiveForm] -> TermFormTemplate
termToTemplate Nothing active = mempty { tftActive = Just active }
termToTemplate (Just Term{..}) active = TermFormTemplate
    { tftName         = Just termName
    , tftStart        = Just termStart
    , tftEnd          = Just termEnd
    , tftHolidays     = Just termHolidays
    , tftLectureStart = Just termLectureStart
    , tftLectureEnd   = Just termLectureEnd
    , tftActive       = Just active
    }

data TermActiveForm = TermActiveForm
  { tafFrom :: UTCTime
  , tafTo :: Maybe UTCTime
  , tafFor :: Maybe UserId
  } deriving (Eq)

termActiveToForm :: TermActive -> TermActiveForm
termActiveToForm TermActive{..} = TermActiveForm
  { tafFrom = termActiveFrom
  , tafTo = termActiveTo
  , tafFor = termActiveFor
  }

data TermForm = TermForm
  { tfName         :: TermIdentifier
  , tfStart        :: Day
  , tfEnd          :: Day
  , tfHolidays     :: [Day]
  , tfLectureStart :: Day
  , tfLectureEnd   :: Day
  , tfActive       :: [TermActiveForm]
  }

newTermForm :: Maybe TermId -> TermFormTemplate -> Form TermForm
newTermForm mtid template = validateForm validateTerm $ \html -> do
    cRoute <- fromMaybe (error "newTermForm called from 404-Handler") <$> getCurrentRoute
    mr <- getMessageRender
    let
      tidForm
        | Just tid <- unTermKey <$> mtid
        = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
        | otherwise
        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
      holidayForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
        where
          miAdd mkUnique submitView csrf = do
            (fromRes, fromView) <- mpreq dayField ("" & addName (mkUnique "from") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
            (toRes, toView) <- mopt dayField ("" & addName (mkUnique "to") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
            let
              holidaysRes = case (fromRes, toRes) of
                (FormSuccess f, FormSuccess (Just t)) -> FormSuccess $ Right (f, t)
                (FormSuccess f, FormSuccess Nothing) -> FormSuccess $ Left f
                (FormSuccess f, FormMissing) -> FormSuccess $ Left f
                (f, tRes) -> fmap Left f <* tRes
              holidaysRes' = holidaysRes <&> \newDat oldDat -> if
                | let newUngrouped = Set.fromList . ungroupHolidays $ pure newDat
                      oldUngrouped = Set.fromList $ ungroupHolidays oldDat
                , newUngrouped `Set.isSubsetOf` oldUngrouped
                  -> FormFailure [mr MsgTermFormHolidaysAlreadyAdded]
                | otherwise
                  -> FormSuccess $ pure newDat
            return (holidaysRes', $(widgetFile "term/holiday-mass-input/add"))
          miCell x = $(widgetFile "term/holiday-mass-input/cell")
            where (f, t) = case x of
                    Left d -> (d, Nothing)
                    Right (f', t') -> (f', Just t')
          miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
          miButtonAction = Just . SomeRoute . (cRoute :#:)
          miLayout :: MassInputLayout ListLength (Either Day (Day, Day)) ()
          miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "term/holiday-mass-input/layout")
          miIdent :: Text
          miIdent = "holidays"
          fSettings = fslI MsgTermHolidays
          fRequired = False
      ungroupHolidays = foldMap $ \case
        Left d -> pure d
        Right (f, t) -> [f..t]
      activeForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
        where
          miAdd mkUnique submitView csrf = do
            (fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing
            (toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing
            (forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for")) Nothing
            
            let res = TermActiveForm <$> fromRes <*> toRes <*> forRes
                res' = res <&> \newDat oldDat -> if
                  | newDat `elem` oldDat
                    -> FormFailure [mr MsgTermFormActiveAlreadyAdded]
                  | otherwise
                    -> FormSuccess $ pure newDat
            return (res', $(widgetFile "term/active-mass-input/add"))
          miCell TermActiveForm{..} = do
            user <- for tafFor $ liftHandler . runDB . get404
            $(widgetFile "term/active-mass-input/cell")
          miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
          miButtonAction = Just . SomeRoute . (cRoute :#:)
          miLayout :: MassInputLayout ListLength TermActiveForm ()
          miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "term/active-mass-input/layout")
          miIdent :: Text
          miIdent = "active-periods"
          fSettings = fslI MsgTermActive
          fRequired = False
    flip (renderAForm FormStandard) html $ TermForm
      <$> tidForm
      <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
      <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
      <*> (ungroupHolidays <$> holidayForm (groupHolidays <$> tftHolidays template))
      <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
      <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
      <*> activeForm (tftActive template)


deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''TermActiveForm