128 lines
6.6 KiB
Haskell
128 lines
6.6 KiB
Haskell
module Handler.Sheet.PersonalisedFiles.Meta
|
|
( formatPersonalisedSheetFilesMeta
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Sheet.PersonalisedFiles.Types
|
|
|
|
import qualified Data.Char as Char
|
|
import qualified Data.Text as Text
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
|
|
|
import qualified Data.YAML as YAML
|
|
import qualified Data.YAML.Event as YAML (untagged)
|
|
import qualified Data.YAML.Event as YAML.Event
|
|
import qualified Data.YAML.Token as YAML (Encoding(..))
|
|
|
|
import Control.Monad.Trans.State.Lazy (evalState)
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
data PrettifyState
|
|
= PrettifyInitial
|
|
| PrettifyFlowSequence PrettifyState
|
|
| PrettifyBlockSequence PrettifyState
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
formatPersonalisedSheetFilesMeta
|
|
:: MonadIO m
|
|
=> PersonalisedSheetFilesDownloadAnonymous
|
|
-> CourseParticipant
|
|
-> CryptoFileNameUser
|
|
-> SqlPersistT m Lazy.ByteString
|
|
formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
|
|
User{..} <- getJust courseParticipantUser
|
|
exams <- E.select . E.from $ \(exam `E.InnerJoin` examRegistration) -> E.distinctOnOrderBy [E.asc $ exam E.^. ExamName] $ do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val courseParticipantCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val courseParticipantUser
|
|
return $ exam E.^. ExamName
|
|
|
|
let uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat
|
|
[ [ YAML.Event.StreamStart
|
|
, YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2
|
|
, YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
|
|
]
|
|
, mapEvents (str' "user") (str $ toPathPiece cID)
|
|
, guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat
|
|
[ mapEvents (str' "display_name") (str userDisplayName)
|
|
, mapEvents (str' "surname") (str userSurname)
|
|
, mapEvents (str' "first_names") (str userFirstName)
|
|
, case userMatrikelnummer of
|
|
Just matr -> mapEvents (str' "matriculation") (str matr)
|
|
Nothing -> mzero
|
|
, mapEvents (str' "email") (str $ CI.original userEmail)
|
|
]
|
|
, map flowStyle $ mapEvents (str' "languages") . YAML.Sequence () YAML.untagged $ maybe [] (views _Wrapped $ map str) userLanguages
|
|
, mapEvents (str' "registered_exams") . YAML.Sequence () YAML.untagged $ map (str . CI.original . E.unValue) exams
|
|
, [ YAML.Event.MappingEnd
|
|
, YAML.Event.DocumentEnd False
|
|
, YAML.Event.StreamEnd
|
|
]
|
|
]
|
|
where
|
|
str :: forall t. Textual t => t -> YAML.Node ()
|
|
str = YAML.Scalar () . YAML.SStr . repack
|
|
str' :: Text -> YAML.Node ()
|
|
str' = str
|
|
|
|
mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event]
|
|
mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v
|
|
where filterEvs ((YAML.Event.MappingStart{} : inner) :> YAML.Event.MappingEnd) = inner
|
|
filterEvs _other = error "Could not strip Mapping"
|
|
|
|
nodeEvents :: YAML.Node () -> [YAML.Event.Event]
|
|
nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc
|
|
where filterEvs = filter $ \case
|
|
YAML.Event.StreamStart -> False
|
|
YAML.Event.StreamEnd -> False
|
|
YAML.Event.DocumentStart _ -> False
|
|
YAML.Event.DocumentEnd _ -> False
|
|
_other -> True
|
|
|
|
flowStyle :: YAML.Event.Event -> YAML.Event.Event
|
|
flowStyle = \case
|
|
YAML.Event.SequenceStart a t _ -> YAML.Event.SequenceStart a t YAML.Event.Flow
|
|
YAML.Event.MappingStart a t _ -> YAML.Event.MappingStart a t YAML.Event.Flow
|
|
other -> other
|
|
|
|
prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML
|
|
where
|
|
transduce' (Left _ : _) = error "Parse error on uglyYAML"
|
|
transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _))
|
|
= (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (`transduce` eEvent)) <*> transduce' es
|
|
transduce' (Right YAML.Event.EvPos{..} : es)
|
|
= (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (`transduce` eEvent)) <*> transduce' es
|
|
transduce' [] = return []
|
|
|
|
annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse
|
|
where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann3, ann2))
|
|
= let (before', after) = Lazy.ByteString.splitAt pos2' dat
|
|
(before, event) = Lazy.ByteString.splitAt pos1' before'
|
|
event' = decodeUtf8 $ toStrict event
|
|
ws = Text.takeWhileEnd Char.isSpace event'
|
|
event'' = Text.dropWhileEnd Char.isSpace event'
|
|
pos1' = min pos1 mLength
|
|
pos2' = min pos2 mLength
|
|
in (before <> ann1 <> fromStrict (encodeUtf8 $ ann3 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1')
|
|
|
|
transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text, Text -> Text), PrettifyState)
|
|
transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Flow) = ((mempty, id, bool " " mempty . null), PrettifyFlowSequence cState)
|
|
transduce (PrettifyFlowSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
|
|
transduce cState@(PrettifyFlowSequence _) _ = ((mempty, f, bool " " mempty . null), cState)
|
|
where f str | ']' `elem` str = filter (/= '\n') str
|
|
| otherwise = str
|
|
-- transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial)
|
|
transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Block) = ((" ", id, id), PrettifyBlockSequence cState)
|
|
transduce (PrettifyBlockSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
|
|
transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n -", id), cState)
|
|
transduce cState _ = ((mempty, id, id), cState)
|
|
-- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO
|
|
return prettyYAML
|