{-# LANGUAGE CPP, FlexibleContexts #-}
module Ideas.Encoding.Logging
( Record(..), addRequest, addState
, LogRef, makeLogRef, defaultLogRef, enableLogging, disableLogging
, changeLog, logEnabled, logRecord, logRecordWith, printLog
, selectFrom
, getRecord
, getFilePath
) where
import Control.Monad
import Data.Char
import Data.IORef
import Data.Maybe
import Data.Semigroup (Semigroup(..))
import Data.Time
import Ideas.Encoding.Request (Request, Schema(..))
import Ideas.Service.State
import qualified Ideas.Encoding.Request as R
#ifdef DB
import Data.List
import Database.HDBC
import Database.HDBC.Sqlite3 (connectSqlite3, setBusyTimeout)
#endif
type Diff = NominalDiffTime
type Time = UTCTime
data Record = Record
{ useLogging :: Bool
, service :: String
, exerciseid :: String
, source :: String
, script :: String
, requestinfo :: String
, dataformat :: String
, encoding :: String
,
userid :: String
, sessionid :: String
, taskid :: String
, time :: Time
, responsetime :: Diff
, ipaddress :: String
, binary :: String
, version :: String
, errormsg :: String
, serviceinfo :: String
, ruleid :: String
, input :: String
, output :: String
}
deriving Show
record :: Record
record = Record True "" "" "" "" "" "" "" "" "" "" t0 0 "" "" "" "" "" "" "" ""
where t0 = UTCTime (toEnum 0) 0
makeRecord :: IO Record
makeRecord = do
now <- getCurrentTime
return record { time = now }
addRequest :: Request -> Record -> Record
addRequest req r = r
{ service = maybe (service r) show (R.serviceId req)
, exerciseid = maybe (exerciseid r) show (R.exerciseId req)
, source = fromMaybe (source r) (R.source req)
, script = fromMaybe (script r) (R.feedbackScript req)
, requestinfo = fromMaybe (requestinfo r) (R.requestInfo req)
, dataformat = show (R.dataformat req)
, encoding = show (R.encoding req)
, binary = fromMaybe (binary r) (R.cgiBinary req)
}
addState :: State a -> Record -> Record
addState st r = r
{ userid = fromMaybe (userid r) (stateUser st)
, sessionid = fromMaybe (sessionid r) (stateSession st)
, taskid = fromMaybe (taskid r) (stateStartTerm st)
}
data LogRef = NoRef | LogRef FilePath Schema (IORef Record)
instance Semigroup LogRef where
NoRef <> r = r
r <> _ = r
instance Monoid LogRef where
mempty = NoRef
mappend = (<>)
defaultLogRef :: IO LogRef
defaultLogRef = makeLogRef "requests.db" V2
makeLogRef :: FilePath -> Schema -> IO LogRef
makeLogRef file schema = do
r <- makeRecord
ref <- newIORef r
return (LogRef file schema ref)
enableLogging :: LogRef -> IO ()
enableLogging = flip changeLog (\r -> r {useLogging = True})
disableLogging :: LogRef -> IO ()
disableLogging = flip changeLog (\r -> r {useLogging = False})
whenLogging :: LogRef -> IO () -> IO ()
whenLogging logRef m = do
r <- getRecord logRef
when (useLogging r) m
getRecord :: LogRef -> IO Record
getRecord NoRef = return record
getRecord (LogRef _ _ r) = readIORef r
getFilePath :: LogRef -> Maybe FilePath
getFilePath NoRef = Nothing
getFilePath (LogRef fp _ _) = Just fp
changeLog :: LogRef -> (Record -> Record) -> IO ()
changeLog NoRef _ = return ()
changeLog (LogRef _ _ r) f = modifyIORef r f
printLog :: LogRef -> IO ()
printLog logRef = do
putStrLn "-- log information"
getRecord logRef >>= print
logEnabled :: Bool
logRecord :: LogRef -> IO ()
selectFrom :: FilePath -> String -> [String] -> ([String] -> IO a) -> IO [a]
#ifdef DB
logEnabled = True
#else
logEnabled = False
logRecord _ = return ()
selectFrom _ _ _ _ = return []
logRecordWith :: LogRef -> c -> IO ()
logRecordWith _ _ = return ()
#endif
#ifdef DB
nameOfTable :: Schema -> String
nameOfTable V1 = "log"
nameOfTable _ = "requests"
columnsInTable :: Schema -> Record -> [SqlValue]
columnsInTable V1 = values_v1
columnsInTable _ = values_v2
values_v1 :: Record -> [SqlValue]
values_v1 r =
let get f = toSql (f r)
in [ get service, get exerciseid, get source, get dataformat, get encoding
, get input, get output, get ipaddress, get time, get responsetime
]
values_v2 :: Record -> [SqlValue]
values_v2 r =
let get f = toSql (f r)
in [ get service, get exerciseid, get source, get script, get requestinfo
, get dataformat, get encoding, get userid, get sessionid, get taskid
, get time, get responsetime, get ipaddress, get binary, get version
, get errormsg, get serviceinfo, get ruleid, get input, get output
]
logRecord NoRef = return ()
logRecord logRef@(LogRef file _ _) =
(whenLogging logRef) $ do
conn <- connectSqlite3 file
setBusyTimeout conn 200
logRecordWith logRef conn
disconnect conn
`catchSql` \_ ->
return ()
logRecordWith :: IConnection c => LogRef -> c -> IO ()
logRecordWith NoRef _ = return ()
logRecordWith logRef@(LogRef _ schema _) conn = do
r <- getRecord logRef
end <- getCurrentTime
let diff = diffUTCTime end (time r)
insertRecord schema r {responsetime = diff} conn
`catchSql` \_ ->
return ()
insertRecord :: IConnection c => Schema -> Record -> c -> IO ()
insertRecord schema r conn =
let cols = columnsInTable schema r
pars = "(" ++ intercalate "," (replicate (length cols) "?") ++ ")"
stm = "INSERT INTO " ++ nameOfTable schema ++ " VALUES " ++ pars
in run conn stm cols >> commit conn
selectFrom database table columns f = do
let sql = "SELECT " ++ commas (map safe columns) ++ " from " ++ safe table
commas = intercalate ","
safe = filter isAlphaNum
con <- connectSqlite3 database
stat <- prepare con sql
_ <- execute stat []
rows <- fetchAllRows stat
xs <- mapM (f . map fromSql) rows
disconnect con
return xs
#endif