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) # 0.2.0.0 (Sep. 23, 2015)
* Add support for user registration * Add support for user registration
......
...@@ -20,6 +20,7 @@ import qualified Database.Redis as R ...@@ -20,6 +20,7 @@ import qualified Database.Redis as R
import API.Controllers.Common import API.Controllers.Common
import API.Database.Common import API.Database.Common
import API.Errors import API.Errors
import API.Logging
import API.Models.Common import API.Models.Common
import qualified API.Database.User as DB import qualified API.Database.User as DB
...@@ -33,8 +34,8 @@ data AuthCheck ...@@ -33,8 +34,8 @@ data AuthCheck
| AuthError | AuthError
| AuthMissing | AuthMissing
login :: Pool -> R.Connection -> ActionT IO () login :: Pool -> R.Connection -> Log -> ActionT IO ()
login sqlC redisC = do login sqlC redisC logger = do
auth <- header "Authorization" auth <- header "Authorization"
ret <- checkSession redisC ret <- checkSession redisC
case ret of case ret of
...@@ -43,9 +44,10 @@ login sqlC redisC = do ...@@ -43,9 +44,10 @@ login sqlC redisC = do
auth' <- liftIO $ checkAuth sqlC auth auth' <- liftIO $ checkAuth sqlC auth
case auth' of case auth' of
AuthError -> errorResponse AuthenticationDown AuthError -> errorResponse AuthenticationDown
(AuthOkay _ _) -> do (AuthOkay (Email n) _) -> do
skey <- liftIO $ makeSession redisC skey <- liftIO $ makeSession redisC logger
setSessionKey skey setSessionKey skey
liftIO $ info logger Login Post $ n <> " has logged in"
noContent noContent
AuthMissing -> errorResponse Unauthorized AuthMissing -> errorResponse Unauthorized
AuthInvalid -> errorResponse BadCredentials AuthInvalid -> errorResponse BadCredentials
...@@ -78,12 +80,14 @@ endSession redisC key = ...@@ -78,12 +80,14 @@ endSession redisC key =
let k = [encodeUtf8 key] let k = [encodeUtf8 key]
in void (runRedis redisC (R.del k)) in void (runRedis redisC (R.del k))
makeSession :: R.Connection -> IO UUID makeSession :: R.Connection -> Log -> IO UUID
makeSession redisC = do makeSession redisC logger = do
u <- nextRandom u <- nextRandom
-- TODO: log the status for this call
let key = toASCIIBytes u 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 return u
parseBasicAuth :: Text -> AuthCheck parseBasicAuth :: Text -> AuthCheck
......
...@@ -8,14 +8,17 @@ import Web.Spock.Shared ...@@ -8,14 +8,17 @@ import Web.Spock.Shared
import API.Models.Common import API.Models.Common
import API.Controllers.Common import API.Controllers.Common
import API.Database.Common import API.Database.Common
import API.Logging
import API.Responses.User import API.Responses.User
import qualified API.Database.User as DB import qualified API.Database.User as DB
registerUser :: MonadIO m => Pool -> ActionT m b registerUser :: MonadIO m => Pool -> Log -> ActionT m b
registerUser sqlC = do registerUser sqlC logger = do
email <- param' "email" email <- param' "email"
pass <- param' "password" pass <- param' "password"
ret <- liftIO $ DB.register sqlC (Email email) (Pass pass) ret <- liftIO $ DB.register sqlC (Email email) (Pass pass)
case ret of case ret of
Left e -> errorResponse e 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 ...@@ -6,9 +6,10 @@ import qualified Hasql as H
import qualified Hasql.Postgres as HP import qualified Hasql.Postgres as HP
import qualified Database.Redis as R import qualified Database.Redis as R
import API.Database.Common
import API.Controllers.Login import API.Controllers.Login
import API.Controllers.Register import API.Controllers.Register
import API.Database.Common
import API.Logging (mkLog, Log)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () main :: IO ()
...@@ -18,16 +19,17 @@ main = do ...@@ -18,16 +19,17 @@ main = do
sqlC :: Pool sqlC :: Pool
<- H.acquirePool psqlConf poolConf <- H.acquirePool psqlConf poolConf
redisC <- R.connect R.defaultConnectInfo redisC <- R.connect R.defaultConnectInfo
logger <- mkLog
runSpock 3000 $ spockT id $ runSpock 3000 $ spockT id $
do core sqlC redisC do core sqlC redisC logger
players players
games games
runs runs
core :: Pool -> R.Connection -> SpockT IO () core :: Pool -> R.Connection -> Log -> SpockT IO ()
core sqlC redisC = core sqlC redisC logger =
do post "register" (registerUser sqlC) do post "register" (registerUser sqlC logger)
post "login" (login sqlC redisC) post "login" (login sqlC redisC logger)
players :: SpockT IO () players :: SpockT IO ()
players = players =
......
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
-- further documentation, see http://haskell.org/cabal/users-guide/ -- further documentation, see http://haskell.org/cabal/users-guide/
name: type-assisted-speed-runs name: type-assisted-speed-runs
version: 0.2.0.0 version: 0.3.0.0
synopsis: A speed-run hosting site synopsis: A speed-run hosting site
homepage: https://gitlab.com/cpp.cabrera/type-assisted-speed-runs homepage: https://gitlab.com/cpp.cabrera/type-assisted-speed-runs
-- description: -- description:
...@@ -34,6 +34,7 @@ library ...@@ -34,6 +34,7 @@ library
, API.Database.Common , API.Database.Common
, API.Database.User , API.Database.User
, API.Errors , API.Errors
, API.Logging
, API.Models , API.Models
, API.Models.Common , API.Models.Common
, API.Models.User , API.Models.User
...@@ -54,6 +55,7 @@ library ...@@ -54,6 +55,7 @@ library
, hasql-backend , hasql-backend
, hasql-postgres , hasql-postgres
, hedis , hedis
, hostname
, http-types , http-types
, monad-control , monad-control
, network , network
...@@ -61,6 +63,7 @@ library ...@@ -61,6 +63,7 @@ library
, text , text
, time , time
, transformers , transformers
, unix
, uuid , uuid
, wai , wai
, wai-extra , 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