fix(health): fix #153 and offer interface health route matching
This commit is contained in:
parent
c71814d1ef
commit
ce3852e3d3
@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Fehlermeldungen
|
||||
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
|
||||
|
||||
InterfacesOk: Schnittstellen sind ok.
|
||||
InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme!
|
||||
InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!
|
||||
InterfaceStatus !ident-ok: Status
|
||||
InterfaceName: Schnittstelle
|
||||
InterfaceLastSynch: Zuletzt
|
||||
|
||||
@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Error Log
|
||||
ProblemsInterfaceSince: Only considering successes and errors since
|
||||
|
||||
InterfacesOk: Interfaces are ok.
|
||||
InterfacesFail n: #{tshow n} Interface problems!
|
||||
InterfacesFail n: #{pluralENsN n "interface problem"}!
|
||||
InterfaceStatus: Status
|
||||
InterfaceName: Interface
|
||||
InterfaceLastSynch: Last
|
||||
|
||||
38
src/Audit.hs
38
src/Audit.hs
@ -8,7 +8,7 @@ module Audit
|
||||
, audit
|
||||
, AuditRemoteException(..)
|
||||
, getRemote
|
||||
, logInterface
|
||||
, logInterface, logInterface'
|
||||
) where
|
||||
|
||||
|
||||
@ -128,11 +128,39 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
|
||||
-> Text -- ^ Any additional information
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
||||
logInterface (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
|
||||
interfaceLogTime <- liftIO getCurrentTime
|
||||
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
|
||||
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
|
||||
deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest
|
||||
insert_ InterfaceLog{..}
|
||||
logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
|
||||
|
||||
logInterface' :: ( AuthId (HandlerSite m) ~ Key User
|
||||
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, YesodAuthPersist (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, HasAppSettings (HandlerSite m)
|
||||
, HasCallStack
|
||||
)
|
||||
=> Text -- ^ Interface that is used
|
||||
-> Text -- ^ Subtype of the interface, if any
|
||||
-> Bool -- ^ True indicates Write Access to FRADrive
|
||||
-> Bool -- ^ Success=True, Failure=False
|
||||
-> Maybe Int -- ^ Number of transmitted datasets
|
||||
-> Text -- ^ Any additional information
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
||||
logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
|
||||
interfaceLogTime <- liftIO getCurrentTime
|
||||
-- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest
|
||||
-- insert_ InterfaceLog{..}
|
||||
void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
|
||||
( InterfaceLog{..} )
|
||||
[ InterfaceLogTime =. interfaceLogTime
|
||||
, InterfaceLogRows =. interfaceLogRows
|
||||
, InterfaceLogInfo =. interfaceLogInfo
|
||||
, InterfaceLogSuccess =. interfaceLogSuccess
|
||||
]
|
||||
audit TransactionInterface
|
||||
{ transactionInterfaceName = interfaceLogInterface
|
||||
, transactionInterfaceSubtype = interfaceLogSubtype
|
||||
|
||||
@ -18,24 +18,21 @@ import Import
|
||||
-- import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Concurrent
|
||||
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on)
|
||||
import qualified Database.Persist.Sql as E (deleteWhereCount)
|
||||
|
||||
|
||||
identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
|
||||
identifyInterfaces [] = []
|
||||
identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing]
|
||||
identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing]
|
||||
identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r
|
||||
|
||||
-- | identify a wildcard argument
|
||||
wc2null :: Text -> Maybe Text
|
||||
wc2null "." = Nothing
|
||||
-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs
|
||||
-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface
|
||||
wc2null "_" = Nothing
|
||||
wc2null "*" = Nothing
|
||||
wc2null o = Just o
|
||||
|
||||
-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
|
||||
@ -45,55 +42,92 @@ pbool (Text.toLower . Text.strip -> w)
|
||||
| w `elem` ["0", "f", "false","falsch"] = Just False
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places.
|
||||
identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
|
||||
identifyInterfaces [] = []
|
||||
identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing]
|
||||
identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing]
|
||||
identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r
|
||||
|
||||
type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth])
|
||||
|
||||
-- | Interface names prefixed with '-' are to be excluded from the query
|
||||
splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth
|
||||
splitInterfaces = foldl' aux mempty
|
||||
where
|
||||
aux (reqs,bans) uih@(UniqueInterfaceHealth i s w)
|
||||
| Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans)
|
||||
| otherwise = (uih : reqs, bans)
|
||||
|
||||
-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second
|
||||
matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
|
||||
matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
|
||||
where
|
||||
eqOrNothing _ Nothing = True
|
||||
eqOrNothing a b = a == b
|
||||
|
||||
|
||||
getHealthInterfaceR :: [Text] -> Handler Html
|
||||
getHealthInterfaceR ris = do
|
||||
let interfs = identifyInterfaces ris
|
||||
(missing, allok, res, iltable) <- runInterfaceLogTable interfs
|
||||
when missing notFound -- send 404 if an interface any interface was not found
|
||||
unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
|
||||
siteLayoutMsg MsgMenuHealthInterface $ do
|
||||
let (forced, ris') = case ris of
|
||||
("force":ris0) -> (True , ris0)
|
||||
_ -> (False, ris )
|
||||
interfs = splitInterfaces $ identifyInterfaces ris'
|
||||
(missing, allok, res, iltable) <- runInterfaceLogTable interfs
|
||||
let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
|
||||
when missing notFound -- send 404 if any requested interface was not found
|
||||
unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg
|
||||
content <- siteLayoutMsg MsgMenuHealthInterface $ do
|
||||
setTitleI MsgMenuHealthInterface
|
||||
[whamlet|
|
||||
Interfaces healthy.
|
||||
$if allok
|
||||
Interfaces are healthy.
|
||||
$else
|
||||
#{badMsg}
|
||||
|
||||
^{iltable}
|
||||
|]
|
||||
sendResponseStatus (bool internalServerError500 status200 allok) content
|
||||
|
||||
|
||||
runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget)
|
||||
runInterfaceLogTable interfs = do
|
||||
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
|
||||
runInterfaceLogTable interfs@(reqIfs,_) = do
|
||||
-- we abuse messageTooltip for colored icons here
|
||||
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
||||
-- msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
msgErrorTooltip <- messageI Error MsgMessageError
|
||||
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
|
||||
(res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
|
||||
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ]
|
||||
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
|
||||
allok = all snd res
|
||||
return (missing, allok, res, twgt)
|
||||
|
||||
-- ihDebugShow :: Unique InterfaceHealth -> Text
|
||||
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")"
|
||||
|
||||
mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable flagError interfs = do
|
||||
runInterfaceChecks
|
||||
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
|
||||
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
|
||||
now <- liftIO getCurrentTime
|
||||
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
|
||||
where
|
||||
sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
|
||||
dbtIdent = "interface-log" :: Text
|
||||
dbtProj = dbtProjId
|
||||
dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
|
||||
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
|
||||
)
|
||||
unless (null interfs) $
|
||||
E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ
|
||||
| (UniqueInterfaceHealth ifce subt writ) <- interfs
|
||||
]
|
||||
let matchUIH crits = E.or
|
||||
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce)
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ
|
||||
| (UniqueInterfaceHealth ifce subt writ) <- crits
|
||||
]
|
||||
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs
|
||||
unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs
|
||||
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
|
||||
return (ilog, ihour)
|
||||
|
||||
@ -147,19 +181,46 @@ mkInterfaceLogTable flagError interfs = do
|
||||
|
||||
|
||||
-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
|
||||
runInterfaceChecks :: DB ()
|
||||
runInterfaceChecks = do
|
||||
avsInterfaceCheck
|
||||
lprAckCheck
|
||||
|
||||
lprAckCheck :: DB ()
|
||||
lprAckCheck = return () -- !!! TODO !!! Stub
|
||||
-- ensure that all received apc-idents were ok
|
||||
runInterfaceChecks :: ReqBanInterfaceHealth -> DB ()
|
||||
runInterfaceChecks interfs = do
|
||||
avsInterfaceCheck interfs
|
||||
lprAckCheck interfs
|
||||
|
||||
avsInterfaceCheck :: DB ()
|
||||
avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let cutOffOldTime = addHours (-interfaceHealthHours) now
|
||||
maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
|
||||
maybeRunCheck (reqIfs,banIfs) uih act
|
||||
| null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs
|
||||
, null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do
|
||||
mih <- getBy uih
|
||||
whenIsJust mih $ \eih -> do
|
||||
now <- liftIO getCurrentTime
|
||||
act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
|
||||
| otherwise = return ()
|
||||
|
||||
-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB ()
|
||||
-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih
|
||||
-- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal)
|
||||
-- where
|
||||
-- ih2hours :: Entity InterfaceHealth -> Int
|
||||
-- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h
|
||||
-- ih2hours = interfaceHealthHours . entityVal
|
||||
|
||||
|
||||
lprAckCheck :: ReqBanInterfaceHealth -> DB ()
|
||||
lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
|
||||
unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] []
|
||||
if notNull unproc
|
||||
then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
|
||||
else do
|
||||
oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
|
||||
if oks > 0
|
||||
then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
|
||||
else mkLog True Nothing mempty
|
||||
where
|
||||
mkLog = logInterface' "Printer" "Acknowledge" True
|
||||
|
||||
|
||||
avsInterfaceCheck :: ReqBanInterfaceHealth -> DB ()
|
||||
avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do
|
||||
avsSynchStats <- E.select $ do
|
||||
uavs <- E.from $ E.table @UserAvs
|
||||
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
|
||||
@ -167,23 +228,21 @@ avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AV
|
||||
E.groupBy isOk
|
||||
E.orderBy [E.descNullsLast isOk]
|
||||
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
|
||||
let
|
||||
let
|
||||
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
|
||||
fmtCut <- formatTime SelFormatDate cutOffOldTime
|
||||
fmtBad <- formatTime SelFormatDateTime badTime
|
||||
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
|
||||
mkBadInfo _ _ = return mempty
|
||||
writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo =
|
||||
void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
|
||||
(InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo))
|
||||
[InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo]
|
||||
--case $(unValueN 3) <$> avsSynchStats of
|
||||
case avsSynchStats of
|
||||
((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
|
||||
writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
|
||||
((E.Value True , E.Value okRows, E.Value okTime):_) ->
|
||||
writeAvsSynchStats (Just okRows) okTime mempty
|
||||
((E.Value False, E.Value badRows, E.Value badTime):_) -> do
|
||||
lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
||||
writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
|
||||
writeAvsSynchStats okRows badInfo =
|
||||
logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo
|
||||
--case $(unValueN 3) <$> avsSynchStats of
|
||||
case avsSynchStats of
|
||||
((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
|
||||
writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime
|
||||
((E.Value True , E.Value okRows, E.Value _okTime):_) ->
|
||||
writeAvsSynchStats (Just okRows) mempty
|
||||
((E.Value False, E.Value badRows, E.Value badTime):_) ->
|
||||
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
||||
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
|
||||
_ -> return ()
|
||||
|
||||
@ -123,6 +123,14 @@ migrateAlwaysSafe = do
|
||||
let itemDay = Map.findWithDefault today item changelogItemDays
|
||||
return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|]
|
||||
in sql
|
||||
-- unless (tableExists "interface_health") $ do
|
||||
-- [executeQQ|
|
||||
-- INSERT INTO "interface_health" (interface, subtype, write, hours)
|
||||
-- VALUES
|
||||
-- ('Printer', 'Acknowledge', True, 168)
|
||||
-- , ('AVS' , 'Synch' , True , 96)
|
||||
-- ON CONFLICT DO NOTHING;
|
||||
-- |]
|
||||
|
||||
{-
|
||||
Confusion about quotes, from the PostgreSQL Manual:
|
||||
|
||||
11
src/Utils.hs
11
src/Utils.hs
@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as CBS
|
||||
import qualified Data.Char as Char
|
||||
-- import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original
|
||||
string2citext :: String -> CI Text
|
||||
string2citext = CI.mk . Text.pack
|
||||
|
||||
text2AlphaNumPlus :: [Char] -> Text -> Text
|
||||
text2AlphaNumPlus =
|
||||
let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z']
|
||||
in \oks ->
|
||||
let aNumPlus = Set.fromList oks <> alphaNum
|
||||
in Text.filter (`Set.member` aNumPlus)
|
||||
|
||||
-- | Convert or remove all non-ascii characters, e.g. for filenames
|
||||
text2asciiAlphaNum :: Text -> Text
|
||||
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
|
||||
text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
|
||||
. Text.replace "ä" "ae"
|
||||
. Text.replace "Ä" "Ae"
|
||||
. Text.replace "Æ" "ae"
|
||||
|
||||
@ -310,6 +310,7 @@ makeLenses_ ''AuthorshipStatementDefinition
|
||||
makeLenses_ ''PrintJob
|
||||
|
||||
makeLenses_ ''InterfaceLog
|
||||
-- makeLenses_ ''InterfaceLog -- not needed
|
||||
|
||||
--------------------------
|
||||
-- Fields for `UniWorX` --
|
||||
|
||||
@ -270,7 +270,7 @@ printLetter' pji pdf = do
|
||||
printJobFile = LBS.toStrict pdf
|
||||
printJobAcknowledged = Nothing
|
||||
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
|
||||
let logInter = flip (logInterface "LPR" qshort) (Just 1)
|
||||
let logInter = flip (logInterface "Printer" qshort) (Just 1)
|
||||
lprPDF printJobFilename pdf >>= \case
|
||||
Left err -> do
|
||||
logInter False err
|
||||
@ -288,7 +288,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown."
|
||||
reprint :: PrintJob -> DB (Either Text Text)
|
||||
reprint pj@PrintJob{..} = do
|
||||
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
|
||||
let logInter = flip (logInterface "LPR" qshort) (Just 1)
|
||||
let logInter = flip (logInterface "Printer" qshort) (Just 1)
|
||||
result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
|
||||
case result of
|
||||
Left err ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user