fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): add another common version of camelToPathPiece

Browse Source
This commit is contained in:
Steffen Jost 2022-02-21 14:34:48 +01:00
parent f5cab6e58b
commit a49c24147e
2 changed files with 14 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
src/Handler/LMS/Result.hs
View File

@ -108,11 +108,12 @@ data LmsResultCsvActionClass = LmsResultInsert
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day, lmsResultInsertTimestamp :: UTCTime } -- TODO: why can't we use LmsResultTableCsv here instead?
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 2 . dropEnd 1 . splitCamel { constructorTagModifier = camelToPathPiece'' 2 1 -- over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 2 . dropEnd 1 . splitCamel
, fieldLabelModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 2
, sumEncoding = TaggedObject "action" "data" , sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction } ''LmsResultCsvAction
@ -171,15 +172,13 @@ mkResultTable sid qsh qid = do
{ dbtCsvRowKey = \LmsResultTableCsv{..} -> { 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 , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
now <- liftIO getCurrentTime
--let LmsResultTableCsv{..} = dbCsvNew --let LmsResultTableCsv{..} = dbCsvNew
--let csvLRTident = error "TODO" --let csvLRTident = error "TODO"
-- csvLRTsuccess = error "TODO" -- csvLRTsuccess = error "TODO"
yield $ LmsResultInsertData yield $ LmsResultInsertData
{ lmsResultInsertIdent = csvLRTident dbCsvNew { lmsResultInsertIdent = csvLRTident dbCsvNew
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew
, lmsResultInsertTimestamp = now
} }
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _ } -> error "UniqueLmsResult was found, but Key no longer exists." DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _ } -> error "UniqueLmsResult was found, but Key no longer exists."
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
@ -199,8 +198,8 @@ mkResultTable sid qsh qid = do
, lmsResultSuccess = lmsResultInsertSuccess , lmsResultSuccess = lmsResultInsertSuccess
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
} }
[ LmsResultSuccess =. lmsResultInsertSuccess [ LmsResultSuccess =. lmsResultInsertSuccess
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
-- queueDBJob -- queueDBJob
-- audit -- audit

8
src/Utils/PathPiece.hs
View File

@ -3,7 +3,7 @@ module Utils.PathPiece
, nullaryPathPiece', nullaryPathPiece, finitePathPiece , nullaryPathPiece', nullaryPathPiece, finitePathPiece
, derivePathPiece , derivePathPiece
, splitCamel , splitCamel
, camelToPathPiece, camelToPathPiece' , camelToPathPiece, camelToPathPiece', camelToPathPiece''
, nameToPathPiece, nameToPathPiece' , nameToPathPiece, nameToPathPiece'
, tuplePathPiece , tuplePathPiece
, pathPieceJSON, pathPieceJSONKey , pathPieceJSON, pathPieceJSONKey
@ -211,9 +211,15 @@ splitCamel = map fromList . reverse . helper (error "hasChange undefined at star
sameCategory = (==) `on` Char.generalCategory sameCategory = (==) `on` Char.generalCategory
-- | convert CamelCase to kebab-case, dropping parts at the start and the end
camelToPathPiece'' :: Textual t => Natural -> Natural -> t -> t
camelToPathPiece'' dropNStart dropNEnd = intercalate "-" . map toLower . drop (fromIntegral dropNStart) . dropEnd (fromIntegral dropNEnd) . splitCamel
-- | convert CamelCase to kebab-case, dropping parts at the start
camelToPathPiece' :: Textual t => Natural -> t -> t camelToPathPiece' :: Textual t => Natural -> t -> t
camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dropN) . splitCamel camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dropN) . splitCamel
-- | convert CamelCase to kebab-case suitable for path pieces
camelToPathPiece :: Textual t => t -> t camelToPathPiece :: Textual t => t -> t
camelToPathPiece = camelToPathPiece' 0 camelToPathPiece = camelToPathPiece' 0