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

fix build

Browse Source
This commit is contained in:
Steffen Jost 2022-09-22 18:12:00 +02:00
parent 9d09ec676a
commit f31e509212
5 changed files with 38 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Application.hs
View File

@ -252,7 +252,7 @@ makeFoundation appSettings''@AppSettings{..} = do
runAppLoggingT tempFoundation $ do
$logInfoS "InstanceID" $ UUID.toText appInstanceID
$logDebugS "Configuration" $ tshow appSettings''
$logDebugS "Configuration" $ tshowShort appSettings''
$logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
smtpPool <- for appSmtpConf $ \c -> do
@ -366,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do
}
return . Just $ mkAvsQuery avsServer avsAuth avsEnv
$logDebugS "Runtime configuration" $ tshow appSettings'
$logDebugS "Runtime configuration" $ tshowShort appSettings'
let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery

2
src/Model/Types/Avs.hs
View File

@ -77,6 +77,7 @@ instance FromJSON AvsPersonId where
instance ToJSON AvsPersonId where
toJSON (AvsPersonId pid) = toJSON pid
newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
@ -88,7 +89,6 @@ instance ToJSON AvsCardNo where
toJSON (AvsCardNo cno) = toJSON cno
data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)

11
src/Settings.hs
View File

@ -243,6 +243,17 @@ data AppSettings = AppSettings
, appCommunicationAttachmentsMaxSize :: Maybe Natural
} deriving Show
-- | Some settings strech for multiple lines
tshowShort :: AppSettings -> Text
tshowShort a = Text.take 256 $ tshow a' -- TODO: show only one line!
where a' = a {
appFileChunkingParams = afcp { fastCDCGearHashTable = error "emptyarray" }
}
afcp = appFileChunkingParams a
-- fcght = fastCDCGearHashTable afcp
data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
| JobsOffload
| JobsDrop

25
src/Utils/Avs.hs
View File

@ -30,27 +30,33 @@ avsApi = Proxy
data AvsQuery where
AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
...
}
-> AvsQuery
-}
data AvsQuery = AvsQuery
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
, avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
, avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
, avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
}
makeLenses_ ''AvsQuery
-- | To query all active licences, a special argument must be prepared
avsQueryAllLicences :: AvsQueryGetLicences
avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences allPersonIds) cliEnv
, avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
, avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
}
where
(rawQueryPerson :<|> rawQueryStatus :<|> rawQueryGetLicences :<|> rawQuerySetLicences) = client avsApi basicAuth
@ -59,5 +65,4 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
catch404toEmpty other = other
allPersonIds :: AvsQueryGetLicences
allPersonIds = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId 0

15
templates/ldap.hamlet
View File

@ -7,9 +7,12 @@
Antwort: #
<dl .deflist>
$forall (lk, lv) <- answers
<dt>
#{show lk}
<dd>
UTF8: #{presentUtf8 lv}
&#8212;
Latin: #{presentLatin1 lv}
$with numv <- length lv
<dt>
#{show lk}
$if 1 < numv
\ (#{show numv})
<dd>
UTF8: #{presentUtf8 lv}
&#8212;
Latin: #{presentLatin1 lv}