Commit ab6a7291 authored by Allele Dev's avatar Allele Dev

add: logging

parent 088b57a6
# 0.3.0.0 (Sep. 23, 2015)
* Add logging support
# 0.2.0.0 (Sep. 23, 2015)
* Add support for user registration
......
......@@ -20,6 +20,7 @@ import qualified Database.Redis as R
import API.Controllers.Common
import API.Database.Common
import API.Errors
import API.Logging
import API.Models.Common
import qualified API.Database.User as DB
......@@ -33,8 +34,8 @@ data AuthCheck
| AuthError
| AuthMissing
login :: Pool -> R.Connection -> ActionT IO ()
login sqlC redisC = do
login :: Pool -> R.Connection -> Log -> ActionT IO ()
login sqlC redisC logger = do
auth <- header "Authorization"
ret <- checkSession redisC
case ret of
......@@ -43,9 +44,10 @@ login sqlC redisC = do
auth' <- liftIO $ checkAuth sqlC auth
case auth' of
AuthError -> errorResponse AuthenticationDown
(AuthOkay _ _) -> do
skey <- liftIO $ makeSession redisC
(AuthOkay (Email n) _) -> do
skey <- liftIO $ makeSession redisC logger
setSessionKey skey
liftIO $ info logger Login Post $ n <> " has logged in"
noContent
AuthMissing -> errorResponse Unauthorized
AuthInvalid -> errorResponse BadCredentials
......@@ -78,12 +80,14 @@ endSession redisC key =
let k = [encodeUtf8 key]
in void (runRedis redisC (R.del k))
makeSession :: R.Connection -> IO UUID
makeSession redisC = do
makeSession :: R.Connection -> Log -> IO UUID
makeSession redisC logger = do
u <- nextRandom
-- TODO: log the status for this call
let key = toASCIIBytes u
_ <- runRedis redisC (R.set key "" >> R.expire key 1200)
reply <- runRedis redisC (R.set key "" >> R.expire key 1200)
case reply of
(Left x) -> err logger Redis Post $ show x
(Right _) -> return ()
return u
parseBasicAuth :: Text -> AuthCheck
......
......@@ -8,14 +8,17 @@ import Web.Spock.Shared
import API.Models.Common
import API.Controllers.Common
import API.Database.Common
import API.Logging
import API.Responses.User
import qualified API.Database.User as DB
registerUser :: MonadIO m => Pool -> ActionT m b
registerUser sqlC = do
registerUser :: MonadIO m => Pool -> Log -> ActionT m b
registerUser sqlC logger = do
email <- param' "email"
pass <- param' "password"
ret <- liftIO $ DB.register sqlC (Email email) (Pass pass)
case ret of
Left e -> errorResponse e
Right u -> created (ViewUser u)
Right u -> do
liftIO $ info logger Registration Post $ "Registered " <> email
created (ViewUser u)
module API.Logging (
-- * Initialize
mkLog,
-- * Context, Types
Context(..),
Method(..),
Log,
-- * Logging
fatal,
err,
warn,
notice,
info,
debug,
flush,
-- * Convenience
(<>)
) where
import Prelude hiding (log)
import Data.Monoid
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format
import Network.HostName
import System.Posix.Process (getProcessID)
import System.Log.FastLogger
type Log = LoggerSet
mkLog :: IO Log
mkLog = newStdoutLoggerSet defaultBufSize
data Context
= Players
| Runs
| Games
| Login
| Registration
| Database
| Redis
data Method
= Get
| Put
| Post
| Delete
instance Show Context where
show Players = "players"
show Runs = "runs"
show Games = "games"
show Login = "login"
show Registration = "registration"
show Database = "database"
show Redis = "redis"
instance Show Method where
show Get = "get"
show Put = "put"
show Post = "post"
show Delete = "delete"
contextStr :: Context -> Method -> LogStr
contextStr c m = toLogStr (show m) <> "-" <> toLogStr (show c)
log :: ToLogStr m => LogStr -> Log -> Context -> Method -> m -> IO ()
log lv l context' method' m = do
now <- getCurrentTime
hname <- fmap toLogStr getHostName
pid <- (toLogStr . show) <$> getProcessID
let locale = defaultTimeLocale
let tForm = "%Y-%m-%dT%H:%M:%SZ"
let projectName = "tas-api"
let timestamp = toLogStr (formatTime locale tForm now)
let ctxt = contextStr context' method'
pushLogStrLn l $ lv
<> ":" <> timestamp
<> ":" <> hname
<> ":" <> projectName
<> ":" <> pid
<> ":" <> ctxt
<> ":" <> toLogStr m
fatal :: ToLogStr m => Log -> Context -> Method -> m -> IO ()
fatal = log "FATAL"
err :: ToLogStr m => Log -> Context -> Method -> m -> IO ()
err = log "ERROR"
warn :: ToLogStr m => Log -> Context -> Method -> m -> IO ()
warn = log "WARNING"
notice :: ToLogStr m => Log -> Context -> Method -> m -> IO ()
notice = log "NOITCE"
info :: ToLogStr m => Log -> Context -> Method -> m -> IO ()
info = log "INFO"
debug :: ToLogStr m => Log -> Context -> Method -> m -> IO ()
debug = log "DEBUG"
flush :: Log -> IO ()
flush = flushLogStr
......@@ -6,9 +6,10 @@ import qualified Hasql as H
import qualified Hasql.Postgres as HP
import qualified Database.Redis as R
import API.Database.Common
import API.Controllers.Login
import API.Controllers.Register
import API.Database.Common
import API.Logging (mkLog, Log)
--------------------------------------------------------------------------------
main :: IO ()
......@@ -18,16 +19,17 @@ main = do
sqlC :: Pool
<- H.acquirePool psqlConf poolConf
redisC <- R.connect R.defaultConnectInfo
logger <- mkLog
runSpock 3000 $ spockT id $
do core sqlC redisC
do core sqlC redisC logger
players
games
runs
core :: Pool -> R.Connection -> SpockT IO ()
core sqlC redisC =
do post "register" (registerUser sqlC)
post "login" (login sqlC redisC)
core :: Pool -> R.Connection -> Log -> SpockT IO ()
core sqlC redisC logger =
do post "register" (registerUser sqlC logger)
post "login" (login sqlC redisC logger)
players :: SpockT IO ()
players =
......
......@@ -2,7 +2,7 @@
-- further documentation, see http://haskell.org/cabal/users-guide/
name: type-assisted-speed-runs
version: 0.2.0.0
version: 0.3.0.0
synopsis: A speed-run hosting site
homepage: https://gitlab.com/cpp.cabrera/type-assisted-speed-runs
-- description:
......@@ -34,6 +34,7 @@ library
, API.Database.Common
, API.Database.User
, API.Errors
, API.Logging
, API.Models
, API.Models.Common
, API.Models.User
......@@ -54,6 +55,7 @@ library
, hasql-backend
, hasql-postgres
, hedis
, hostname
, http-types
, monad-control
, network
......@@ -61,6 +63,7 @@ library
, text
, time
, transformers
, unix
, uuid
, wai
, wai-extra
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment