Initial passwords can now be exported in Xlsx

.gitmodules

@@ -13,3 +13,6 @@
 [submodule "submodules/hs-webdriver"]
 	path = submodules/hs-webdriver
 	url = https://github.com/zerobuzz/hs-webdriver
+[submodule "submodules/xlsx-templater"]
+	path = submodules/xlsx-templater
+        url = https://github.com/np/xlsx-templater

aula.cabal

@@ -194,6 +194,8 @@ library
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
   exposed-modules:
@@ -335,6 +337,8 @@ executable aula-avatars
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
     , aula
@@ -409,6 +413,8 @@ executable aula-html-dummies
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
     , aula
@@ -486,6 +492,8 @@ executable aula-i18n
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
     , aula
@@ -562,6 +570,8 @@ executable aula-init-state
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
     , aula
@@ -636,6 +646,8 @@ executable aula-server
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
     , aula
@@ -711,6 +723,8 @@ test-suite spec
     , wai-app-static
     , wai-middleware-metrics
     , warp
+    , xlsx
+    , xlsx-templater
     , yaml
     , zip-archive
     , aula

package.yaml

@@ -93,6 +93,8 @@ dependencies:
     - wai-app-static
     - wai-middleware-metrics
     - warp
+    - xlsx
+    - xlsx-templater
     - yaml
     - zip-archive
 

src/Arbitrary.hs

@@ -878,6 +878,10 @@ instance Arbitrary InitialPasswordsCsv where
     arbitrary = garbitrary
     shrink    = gshrink
 
+instance Arbitrary InitialPasswordsXlsx where
+    arbitrary = garbitrary
+    shrink    = gshrink
+
 instance Arbitrary CsvUserRecord where
     arbitrary = garbitrary
     shrink    = gshrink

src/Frontend.hs

@@ -407,7 +407,8 @@ type AulaAdmin =
   :<|> SchoolClass ::> "delete" :> PostH NeedAdmin
        -- event log
   :<|> "event"  :> FormHandler PageAdminSettingsEventsProtocol
-  :<|> "downloads" :> "passwords" :> Capture "schoolclass" SchoolClass :> GetCSV InitialPasswordsCsv
+  :<|> "downloads" :> "passwords" :> Capture "schoolclass" SchoolClass :> "csv"  :> GetCSV  InitialPasswordsCsv
+  :<|> "downloads" :> "passwords" :> Capture "schoolclass" SchoolClass :> "xlsx" :> GetXLSX InitialPasswordsXlsx
   :<|> "downloads" :> "events" :> QueryParam "space" IdeaSpace :> GetCSV EventLog
   :<|> Topic ::> "next-phase" :> PostH (NeedCap 'CanPhaseForwardTopic)
   :<|> Topic ::> "voting-prev-phase" :> PostH (NeedCap 'CanPhaseBackwardTopic)
@@ -433,6 +434,7 @@ aulaAdmin =
   :<|> runAdminHandler . Page.adminDestroyClass
   :<|> form Page.adminEventsProtocol
   :<|> runGetHandler . Page.adminInitialPasswordsCsv
+  :<|> runGetHandler . Page.adminInitialPasswordsXlsx
   :<|> runGetHandler . adminEventLogCsv
   :<|> postWithTopic (Action.topicForcePhaseChange Forward)
   :<|> postWithTopic (Action.topicForcePhaseChange Backward)

src/Frontend/Core.hs

@@ -24,7 +24,7 @@ module Frontend.Core
 
       -- * helpers for routing tables
     , Singular, CaptureData, (::>), Reply, GetResult(..), PostResult(..), PostResult'
-    , GetH, PostH, FormHandler, GetCSV, Redirect
+    , GetH, PostH, FormHandler, GetCSV, GetXLSX, Redirect
 
       -- * helpers for handlers
     , semanticDiv, semanticDiv', semanticDivAttr
@@ -180,6 +180,9 @@ instance SOP.Generic (GetResult a)
 instance MimeRender CSVZIP a => MimeRender CSVZIP (GetResult a) where
     mimeRender p = mimeRender p . fromGetResult
 
+instance MimeRender XLSX a => MimeRender XLSX (GetResult a) where
+    mimeRender p = mimeRender p . fromGetResult
+
 instance MimeRender PlainText a => MimeRender PlainText (GetResult a) where
     mimeRender p = mimeRender p . fromGetResult
 
@@ -222,6 +225,7 @@ type FormHandler p =
   :<|> FormReqBody :> PostH' (Frame (FormPageRep p)) (Frame (FormPageRep p)) -- Redirect
 
 type GetCSV a = Get '[CSVZIP] (GetResult (CsvHeaders a))
+type GetXLSX a = Get '[XLSX] (GetResult a)
 
 instance Page () where
     isAuthorized = publicPage

src/Frontend/Page/Admin.hs

@@ -18,11 +18,15 @@
 module Frontend.Page.Admin
 where
 
+import Codec.Xlsx (fromXlsx, toXlsx, xlSheets, CellValue(CellText))
+import Codec.Xlsx.Templater
 import Control.Arrow ((&&&))
 import Data.Set (Set)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import Servant
 
 import qualified Data.Csv as Csv
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as ST
 import qualified Generics.SOP as SOP
@@ -719,8 +723,10 @@ instance FormPage AdminEditClass where
                             ]
                             (U.adminDeleteClass schoolClss) "Klasse löschen!"
             hr_ []
-            div_ $ a_ [class_ "admin-buttons", href_ . U.adminDlPass $ schoolClss]
-                "Passwort-Liste"
+            div_ $ do
+                "Passwort-Liste "
+                a_ [class_ "admin-buttons", href_ . U.adminDlPassXlsx $ schoolClss] "(XLSX)"
+                a_ [class_ "admin-buttons", href_ . U.adminDlPassCsv  $ schoolClss] "(CSV)"
             hr_ []
             table_ [class_ "admin-table"] $ do
                 thead_ . tr_ $ do
@@ -1052,6 +1058,8 @@ adminTermsOfUse = formPageHandlerWithMsg
 
 
 -- * csv file handling
+-- TODO CsvUserRecord and InitialPasswordsCsv are also used for XLSX exports so they
+-- could be renamed.
 
 data CsvUserRecord = CsvUserRecord
     { _csvUserRecordFirst       :: UserFirstName
@@ -1062,6 +1070,8 @@ data CsvUserRecord = CsvUserRecord
     }
   deriving (Eq, Ord, Show, Read, Generic)
 
+makeLenses ''CsvUserRecord
+
 instance SOP.Generic CsvUserRecord
 
 data InitialPasswordsCsv = InitialPasswordsCsv Timestamp [CsvUserRecord]
@@ -1132,17 +1142,64 @@ instance MimeRender CSVZIP InitialPasswordsCsv where  -- FIXME: handle null case
 csvUserRecordHeaders :: [String]
 csvUserRecordHeaders = ["Vorname", "Nachname", "email", "login", "Initiales Passwort"]
 
+csvUserRecord :: User -> Maybe CsvUserRecord
+csvUserRecord u =
+    Just $ CsvUserRecord
+            (u ^. userFirstName)
+            (u ^. userLastName)
+            (u ^. userEmail)
+            (Just $ u ^. userLogin)
+            (u ^? userPassword . _UserPassInitial . unInitialPassword)
+{-
+    UserPassInitial (InitialPassword ps) -> Just $ CsvUserRecord
+            (u ^. userFirstName)
+            (u ^. userLastName)
+            (u ^. userEmail)
+            (Just $ u ^. userLogin)
+            (Just ps)
+    _ -> Nothing
+-}
+
 adminInitialPasswordsCsv :: ActionM m => SchoolClass -> m (CsvHeaders InitialPasswordsCsv)
 adminInitialPasswordsCsv clss = do
     now <- getCurrentTimestamp
     csvZipHeaders ("Passwortliste " <> clss ^. uilabeled) .
-        InitialPasswordsCsv now . catMaybes . fmap mk <$> query (getUsersInClass clss)
+        InitialPasswordsCsv now . catMaybes . fmap csvUserRecord <$> query (getUsersInClass clss)
+
+
+-- xlsx
+
+newtype InitialPasswordsXlsx = InitialPasswordsXlsx LBS
+    deriving (Eq, Ord, Show, Read, Generic)
+
+instance SOP.Generic InitialPasswordsXlsx
+
+instance Page InitialPasswordsXlsx where
+    isAuthorized = adminPage
+    isResponsive _ = False
+
+instance MimeRender XLSX InitialPasswordsXlsx where
+    mimeRender Proxy (InitialPasswordsXlsx x) = x
+
+adminInitialPasswordsXlsx :: ActionM m => SchoolClass -> m InitialPasswordsXlsx
+adminInitialPasswordsXlsx clss = do
+    now <- (utcTimeToPOSIXSeconds . unTimestamp) <$> getCurrentTimestamp
+    tplFile <- readTempFile "static-src/initial-passwords.xlsx"
+    tplData <- g . map f . catMaybes . fmap csvUserRecord <$> query (getUsersInClass clss)
+    pure . InitialPasswordsXlsx . fromXlsx now . setSheetName . applyTemplateOnXlsx tplData $
+        toXlsx tplFile
   where
-    mk u = case u ^. userPassword of
-        UserPassInitial (InitialPassword ps) -> Just $ CsvUserRecord
-              (u ^. userFirstName)
-              (u ^. userLastName)
-              (u ^. userEmail)
-              (Just $ u ^. userLogin)
-              (Just ps)
-        _ -> Nothing
+    setSheetName = xlSheets . each . _1 .~ clss ^. uilabeled
+    g :: [TemplateDataRow] -> [(TemplateDataRow, TemplateSettings, [TemplateDataRow])]
+    g rows = [( Map.empty -- Here goes a map with global placeholders, we don't have any yet (classname ?)
+              , TemplateSettings Rows 0 -- We repeat the row 1
+              , rows
+              )]
+    f :: CsvUserRecord -> TemplateDataRow
+    f u = Map.fromList
+            [ ("firstname", CellText $ u ^. csvUserRecordFirst . _UserFirstName)
+            , ("lastname",  CellText $ u ^. csvUserRecordLast  . _UserLastName)
+            , ("email",     CellText $ u ^. csvUserRecordEmail . _Just . re emailAddress)
+            , ("login",     CellText $ u ^. csvUserRecordLogin . _Just . _UserLogin)
+            , ("password",  CellText $ u ^. csvUserRecordInitialPass . _Just)
+            ]

src/Frontend/Path.hs

@@ -123,7 +123,8 @@ module Frontend.Path
     , adminEditClass
     , adminDeleteUser
     , adminDeleteClass
-    , adminDlPass
+    , adminDlPassXlsx
+    , adminDlPassCsv
     , adminTopicNextPhase
     , adminTopicVotingPrevPhase
     , adminTermsOfUse
@@ -456,7 +457,8 @@ data AdminMode (r :: AllowedMethod) =
   | AdminDeleteClass SchoolClass
   | AdminViewClasses (Maybe ClassesFilterQuery)
   | AdminEvent
-  | AdminDlPass SchoolClass
+  | AdminDlPassCsv SchoolClass
+  | AdminDlPassXlsx SchoolClass
   | AdminDlEvents (Maybe IdeaSpace)
   | AdminTopicNextPhase (AUID Topic)
   | AdminTopicVotingPrevPhase (AUID Topic)
@@ -482,8 +484,11 @@ adminDeleteUser = Admin . AdminDeleteUser . view _Id
 adminDeleteClass :: SchoolClass -> Main 'AllowPost
 adminDeleteClass = Admin . AdminDeleteClass
 
-adminDlPass :: SchoolClass -> Main 'AllowGetPost
-adminDlPass = Admin . AdminDlPass
+adminDlPassXlsx :: SchoolClass -> Main 'AllowGetPost
+adminDlPassXlsx = Admin . AdminDlPassXlsx
+
+adminDlPassCsv :: SchoolClass -> Main 'AllowGetPost
+adminDlPassCsv = Admin . AdminDlPassCsv
 
 adminDuration :: Main 'AllowGetPost
 adminDuration = Admin AdminDuration
@@ -530,7 +535,8 @@ adminMode AdminCreateClass                path = path </> "class" </> "create"
 adminMode (AdminEditClass clss)           path = path </> "class" </> uriPart clss </> "edit"
 adminMode (AdminDeleteClass clss)         path = path </> "class" </> uriPart clss </> "delete"
 adminMode AdminEvent                      path = path </> "event"
-adminMode (AdminDlPass clss)              path = path </> "downloads" </> "passwords" </> uriPart clss
+adminMode (AdminDlPassCsv clss)           path = path </> "downloads" </> "passwords" </> uriPart clss </> "csv"
+adminMode (AdminDlPassXlsx clss)          path = path </> "downloads" </> "passwords" </> uriPart clss </> "xlsx"
 adminMode (AdminDlEvents mspc)            path = path </> "downloads" </> "events"
                                                  </?> ("space", cs . toUrlPiece <$> mspc)
 adminMode (AdminTopicNextPhase tid)       path = path </> "topic" </> uriPart tid </> "next-phase"

src/Types/Core.hs

@@ -650,6 +650,14 @@ zipLbs now fname content =
         [Zip.toEntry fname (timestampToEpoch now) content] Nothing ""
 
 
+-- * xlsx helpers
+
+data XLSX
+
+instance Accept XLSX where
+    contentType Proxy = "application" // "vnd.openxmlformats-officedocument.spreadsheetml.sheet"
+
+
 -- * misc
 
 newtype DurationDays = DurationDays { unDurationDays :: Int }

stack.yaml

@@ -7,6 +7,7 @@ resolver: lts-6.3
 packages:
 - '.'
 - submodules/hs-webdriver
+- submodules/xlsx-templater
 
 # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
 extra-deps:
@@ -21,6 +22,7 @@ extra-deps:
 - unordered-containers-0.2.7.0
 - uri-bytestring-0.1.9.2
 - wai-digestive-functors-0.3
+- xlsx-0.4.1
 
 # Override default flag values for local packages and extra-deps
 flags: {}