From f31e5092126167b639c65b9ac543e8986775aaad Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 22 Sep 2022 18:12:00 +0200 Subject: [PATCH] fix build --- src/Application.hs | 4 ++-- src/Model/Types/Avs.hs | 2 +- src/Settings.hs | 11 +++++++++++ src/Utils/Avs.hs | 25 +++++++++++++++---------- templates/ldap.hamlet | 15 +++++++++------ 5 files changed, 38 insertions(+), 19 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 13c579056..b34347390 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index a4a251279..50e2a9d78 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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) diff --git a/src/Settings.hs b/src/Settings.hs index fb471d603..4ff3c29e3 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index eda22e863..6dd39d705 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -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 + diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet index 0b5873a55..150d1fa47 100644 --- a/templates/ldap.hamlet +++ b/templates/ldap.hamlet @@ -7,9 +7,12 @@ Antwort: #
$forall (lk, lv) <- answers -
- #{show lk} -
- UTF8: #{presentUtf8 lv} - — - Latin: #{presentLatin1 lv} + $with numv <- length lv +
+ #{show lk} + $if 1 < numv + \ (#{show numv}) +
+ UTF8: #{presentUtf8 lv} + — + Latin: #{presentLatin1 lv}