chore(lms): import ought to work now

models/lms.model

@@ -115,7 +115,7 @@ LmsResult
   ident             LmsIdent
   success           Day
   timestamp         UTCTime default=now()
-  UniqueLmsResult qualification ident success 
+  UniqueLmsResult qualification ident success -- required by DBTable
   deriving Generic
 
 -- Logs all processed rows from LmsUserlist and LmsResult

routes

@@ -255,6 +255,7 @@
 !/*WellKnownFileName WellKnownR GET !free
 
 -- OSIS CSV Export Demo
-/lms/#SchoolId/#QualificationShorthand              LmsR  				GET
+/lms/#SchoolId/#QualificationShorthand              LmsR  				GET POST
-/lms/#SchoolId/#QualificationShorthand/userlist     LmsUserlistR	GET
+/lms/#SchoolId/#QualificationShorthand/userlist     LmsUserlistR	GET POST
-/lms/#SchoolId/#QualificationShorthand/result       LmsResultR    GET
+/lms/#SchoolId/#QualificationShorthand/result       LmsResultR    GET POST
+ 

src/Handler/Exam/Users.hs

@@ -600,7 +600,7 @@ postEUsersR tid ssh csh examn = do
             , dbtCsvName, dbtCsvSheetName
             , dbtCsvNoExportData = Just id
             , dbtCsvHeader       = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
-            , dbtCsvExampleData = Nothing
+            , dbtCsvExampleData  = Nothing
             }
             where
               doEncode' = ExamUserTableCsv

src/Handler/LMS.hs

@@ -4,9 +4,9 @@
 
 
 module Handler.LMS
-  ( getLmsR
+  ( getLmsR        , postLmsR
-  , getLmsUserlistR  
+  , getLmsUserlistR, postLmsUserlistR
-  , getLmsResultR  
+  , getLmsResultR  , postLmsResultR
   )
   where
 
@@ -62,19 +62,11 @@ csvLmsUserlistFilename = makeLmsFilename "userliste"
 csvLmsResultFilename :: MonadHandler m => m Text
 csvLmsResultFilename = makeLmsFilename "ergebnisse"
 
--- | Create filenames as specified by the LMS interface agreed with Know How AG
-makeLmsFilename :: MonadHandler m => Text -> m Text 
-makeLmsFilename ftag = do 
-  ymth <- getYMTH
-  return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv"
-
--- | Return current datetime in YYYYMMDDHH format 
-getYMTH :: MonadHandler m => m Text 
-getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
 
 
-getLmsR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
-getLmsR sid qsh = do  
+getLmsR = postLmsR
+postLmsR sid qsh = do
   _qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
   -- TODO !!! filter table by qid !!!
   {-
@@ -176,8 +168,9 @@ mkUserlistTable qid = do
   dbTable userlistDBTableValidator userlistTable
 
 
-getLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserlistR sid qsh = do  
+getLmsUserlistR = postLmsUserlistR 
+postLmsUserlistR sid qsh = do
   lmsTable <- runDB $ do
     qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
     view _2 <$> mkUserlistTable qid
@@ -188,4 +181,3 @@ getLmsUserlistR sid qsh = do
 
 -- See Module Handler.LMS.Result for
 -- getLmsResultR :: QualificationId -> Handler Html
-    

src/Handler/LMS/Result.hs

@@ -5,7 +5,8 @@
 
 
 module Handler.LMS.Result
-  ( getLmsResultR
+  ( makeLmsFilename
+  , getLmsResultR, postLmsResultR 
   )
   where
 
@@ -25,6 +26,15 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
+-- | Create filenames as specified by the LMS interface agreed with Know How AG
+makeLmsFilename :: MonadHandler m => Text -> m Text
+makeLmsFilename ftag = do
+  ymth <- getYMTH
+  return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv"
+
+-- | Return current datetime in YYYYMMDDHH format
+getYMTH :: MonadHandler m => m Text
+getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
 
 
 type LmsResultTableExpr = (             E.SqlExpr (Entity Qualification)
@@ -74,12 +84,6 @@ data LmsResultTableCsv = LmsResultTableCsv
   deriving Generic
 makeLenses_ ''LmsResultTableCsv
 
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1 -- TODO: purpose of dropping here is?
-  , fieldLabelModifier = camelToPathPiece' 2  
-  } ''LmsResultTableCsv
-
-
 -- csv without headers
 instance Csv.ToRecord   LmsResultTableCsv -- default suffices
 instance Csv.FromRecord LmsResultTableCsv -- default suffices
@@ -114,13 +118,13 @@ data LmsResultCsvActionClass = LmsResultInsert
   deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
 embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
 
--- TODO: why can't we use LmsResultTableCsv here instead?
+-- By coincidence the action type is identical to LmsResultTableCsv
 data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1
+  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
-  , fieldLabelModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2          -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
   , sumEncoding = TaggedObject "action" "data"
   } ''LmsResultCsvAction
 
@@ -174,22 +178,30 @@ mkResultTable sid qsh qid = do
         dbtIdent :: Text
         dbtIdent = "lms-userlist"
         dbtCsvEncode = Nothing                
-        dbtCsvDecode = Just $ DBTCsvDecode -- Just save to DB; Job will process data later
+        {-
+        dbtCsvEncode = Just DBTCsvEncode
+          { dbtCsvExportForm   = pure ()
+          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
+          , dbtCsvName         = makeLmsFilename "ergebnisse"
+          , dbtCsvSheetName    = makeLmsFilename "ergebnisse"
+          , dbtCsvNoExportData = Just id
+          , dbtCsvHeader       = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
+          , dbtCsvExampleData  = Nothing
+          -}
+
+        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
           { dbtCsvRowKey = \LmsResultTableCsv{..} -> 
-            fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
+              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                 
-                --let LmsResultTableCsv{..} = dbCsvNew 
-                --let csvLRTident = error "TODO"
-                --    csvLRTsuccess = error "TODO"
                 yield $ LmsResultInsertData
                         { lmsResultInsertIdent      = csvLRTident   dbCsvNew
                         , lmsResultInsertSuccess    = csvLRTsuccess dbCsvNew                        
                         }                              
-              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _ } -> error "UniqueLmsResult was found, but Key no longer exists."
+              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists."
               DBCsvDiffMissing{}  -> return () -- no deletion
               DBCsvDiffExisting{} -> return () -- no merge                      
-          , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert
+          , dbtCsvClassifyAction      = \LmsResultInsertData{} -> LmsResultInsert
           , dbtCsvCoarsenActionClass  = \LmsResultInsert -> DBCsvActionNew   -- there is only one action: insert into table
           , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
           , dbtCsvExecuteActions      = do
@@ -205,10 +217,15 @@ mkResultTable sid qsh qid = do
                   [ LmsResultSuccess          =. lmsResultInsertSuccess
                   , LmsResultTimestamp        =. now
                   ]
-                -- queueDBJob 
+                -- queueDBJob?? -- todo
                 -- audit 
             return $ LmsResultR sid qsh 
-          , dbtCsvRenderKey           = error "TODO" -- what is the purpose?
+          , dbtCsvRenderKey           = \_ LmsResultInsertData{..} -> do 
+              [whamlet|
+                $newline never
+                Ident #{getLmsIdent lmsResultInsertIdent} #
+                had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
+              |]
           , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
           , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
           }                    
@@ -218,8 +235,9 @@ mkResultTable sid qsh qid = do
       & defaultSorting [SortAscBy "ident"]
   dbTable resultDBTableValidator resultDBTable
 
-getLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsResultR,  postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsResultR sid qsh = do
+getLmsResultR = postLmsResultR
+postLmsResultR sid qsh = do
   lmsTable <- runDB $ do 
     qid <- getKeyBy404 $ UniqueSchoolShort sid qsh 
     view _2 <$> mkResultTable sid qsh qid 

test/Database/Fill.hs

@@ -457,7 +457,8 @@ fillDb = do
   for_ [jost] $ \uid ->
     void . insert' $ UserSchool uid avn False
 
-  -- void . insert'
+  _qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein"  Nothing (Just 24) (Just $ 5 * 12) Nothing True 
+  _qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88