fradrive/src/Handler/LMS/Result.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only

module Handler.LMS.Result
  ( getLmsResultR, postLmsResultR 
  )
  where

import Import

import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.LMS

import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E


data LmsResultTableCsv = LmsResultTableCsv
  { csvLRTident   :: LmsIdent
  , csvLRTsuccess :: Day
  }
  deriving Generic
makeLenses_ ''LmsResultTableCsv

-- csv without headers -- TODO not yet supported
instance Csv.ToRecord   LmsResultTableCsv -- default suffices
instance Csv.FromRecord LmsResultTableCsv -- default suffices

-- csv with headers 
lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]

instance ToNamedRecord LmsResultTableCsv where
  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
    [ csvResultIdent    Csv..= csvLRTident
    , csvResultSuccess  Csv..= csvLRTsuccess
    ]

instance FromNamedRecord LmsResultTableCsv where
  parseNamedRecord (lsfHeaderTranslate -> csv)
    = LmsResultTableCsv
        <$> csv Csv..: csvResultIdent
        <*> csv Csv..: csvResultSuccess

instance CsvColumnsExplained LmsResultTableCsv where
  csvColumnsExplanations _ = mconcat
    [ single csvResultIdent     MsgCsvColumnLmsIdent
    , single csvResultSuccess   MsgCsvColumnLmsSuccess
    ]
    where
      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
      single k v = singletonMap k [whamlet|_{v}|]

data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
  deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id

-- By coincidence the action type is identical to LmsResultTableCsv
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
                        | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
  , fieldLabelModifier = camelToPathPiece' 2          -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
  , sumEncoding = TaggedObject "action" "data"
  } ''LmsResultCsvAction

data LmsResultCsvException 
  = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
  deriving (Show, Generic, Typeable)

instance Exception LmsResultCsvException
embedRenderMessage ''UniWorX ''LmsResultCsvException id 

mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do  
  dbtCsvName <- csvFilenameLmsResult qsh
  let dbtCsvSheetName = dbtCsvName
  let
    resultDBTable = DBTable{..}
      where

        dbtSQLQuery lmsresult = do
          E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
          return lmsresult
        dbtRowKey = (E.^. LmsResultId)
        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just csvResultIdent)   (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
          , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess            -> success) -> dayCell success
          , sortable (Just csvLmsTimestamp)  (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp        -> timestamp) -> dateTimeCell timestamp
          ] 
        dbtSorting = Map.fromList
          [ (csvResultIdent  , SortColumn (E.^. LmsResultIdent))
          , (csvResultSuccess, SortColumn (E.^. LmsResultSuccess))
          , (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp))
          ]
        dbtFilter = Map.fromList
          [ (csvResultIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
          , (csvResultSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsResultSuccess))
          ]
        dbtFilterUI = \mPrev -> mconcat 
          [ prismAForm (singletonFilter csvResultIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
          , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsSuccess)
          ]
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "lms-result"        
        dbtCsvEncode = Just DBTCsvEncode
          { dbtCsvExportForm   = pure ()
          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
          , dbtCsvName 
          , dbtCsvSheetName
          , dbtCsvNoExportData = Just id
          , dbtCsvHeader       = const $ return lmsResultTableCsvHeader
          , dbtCsvExampleData  = Nothing
          }
          where 
            doEncode' = LmsResultTableCsv
              <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
              <*> view (_dbrOutput . _entityVal . _lmsResultSuccess)
        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
          { dbtCsvRowKey = \LmsResultTableCsv{..} -> 
              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do                 
                yield $ LmsResultInsertData
                        { lmsResultInsertIdent   = csvLRTident   dbCsvNew
                        , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew                        
                        }                              
              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
              DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}} -> do
                yield $ LmsResultUpdateData
                        { lmsResultInsertIdent   = csvLRTident
                        , lmsResultInsertSuccess = csvLRTsuccess 
                        }
              DBCsvDiffMissing{}  -> return () -- no deletion
          , dbtCsvClassifyAction      = \case 
              LmsResultInsertData{} -> LmsResultInsert
              LmsResultUpdateData{} -> LmsResultUpdate 
          , dbtCsvCoarsenActionClass  = \case
              LmsResultInsert -> DBCsvActionNew   
              LmsResultUpdate -> DBCsvActionExisting
          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
          , dbtCsvExecuteActions      = do
            C.mapM_ $ \actionData -> do 
                now <- liftIO getCurrentTime
                void $ upsert 
                  LmsResult
                    { lmsResultQualification  =  qid 
                    , lmsResultIdent          =  lmsResultInsertIdent   actionData
                    , lmsResultSuccess        =  lmsResultInsertSuccess actionData
                    , lmsResultTimestamp      =  now -- lmsResultInsertTimestamp -- does it matter which one to choose?
                    }
                  [ LmsResultSuccess          =. lmsResultInsertSuccess actionData
                  , LmsResultTimestamp        =. now
                  ]
                -- queueDBJob?? -- todo
                -- audit 
            return $ LmsResultR sid qsh 
          , dbtCsvRenderKey           = const $ \case 
              LmsResultInsertData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Insert: Ident #{getLmsIdent lmsResultInsertIdent} #
                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
                |]
              LmsResultUpdateData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Update: Ident #{getLmsIdent lmsResultInsertIdent} #
                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
                |]
          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
          }                    
        dbtExtraReps = []

    resultDBTableValidator = def
      & defaultSorting [SortAscBy csvResultIdent]
  dbTable resultDBTableValidator resultDBTable

getLmsResultR,  postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do
  lmsTable <- runDB $ do 
    qid <- getKeyBy404 $ UniqueSchoolShort sid qsh 
    view _2 <$> mkResultTable sid qsh qid 
  siteLayoutMsg MsgMenuLmsResult $ do
    setTitleI MsgMenuLmsResult
    $(widgetFile "lms-result")