Commit c9e414f5 authored by Allele Dev's avatar Allele Dev

add: viewPlayer

parent 880ef853
# 0.3.1.0 (Sep. 24, 2015)
* Implement viewPlayer
* Add support for NotFound errors
* Add support for generic bad request errors
# 0.3.0.0 (Sep. 23, 2015)
* Add logging support
......
......@@ -48,10 +48,10 @@ unauthorized e = setStatus HTTP.status401 >> json e
forbidden :: (ToJSON a, MonadIO m) => a -> ActionT m b
forbidden e = setStatus HTTP.status403 >> json e
{-
notFound :: (ToJSON a, MonadIO m) => a -> ActionT m b
notFound e = setStatus HTTP.status404 >> json e
{-
rateLimited :: (ToJSON a, MonadIO m) => a -> ActionT m b
rateLimited e = setStatus HTTP.status429 >> json e
......@@ -69,3 +69,5 @@ errorResponse e@Unauthorized = unauthorized e
errorResponse e@BadCredentials = forbidden e
errorResponse e@UserExists = badRequest e
errorResponse e@(DBError _) = badRequest e
errorResponse e@(BadRequest _) = badRequest e
errorResponse e@(NotFound _) = notFound e
......@@ -48,6 +48,7 @@ login sqlC redisC logger = do
skey <- liftIO $ makeSession redisC logger
setSessionKey skey
liftIO $ info logger Login Post $ n <> " has logged in"
-- TODO: update last_login field for users
noContent
AuthMissing -> errorResponse Unauthorized
AuthInvalid -> errorResponse BadCredentials
......
module API.Controllers.Players (
viewPlayer
) where
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import Data.UUID (fromText)
import Web.Spock.Shared
import API.Controllers.Common
import API.Responses.User
import API.Database.Common
import API.Database.User
import API.Models.Common
import API.Errors
viewPlayer :: Pool -> Text -> ActionT IO ()
viewPlayer sqlC playerId =
case fromText playerId of
Nothing -> errorResponse (BadRequest "Invalid player ID: expecting UUID")
(Just pid) -> do
player <- liftIO $ lookupPlayerById sqlC (PlayerId pid)
case player of
Left e -> errorResponse e
Right p -> json (ViewUser p)
......@@ -4,6 +4,7 @@ module API.Database.User (
register,
findUserByEmail,
createUser,
lookupPlayerById,
AuthOutcome(..)
) where
......@@ -61,17 +62,36 @@ register sqlC email (Pass pass) = do
x <- H.session sqlC $ H.tx serialW $ do
(exists :: Maybe (One UUID)) <- findUserByEmail email
case exists of
Just _ -> return $ Left ()
Nothing -> Right <$> createUser email pass_hash displayName now
Just _ -> return Nothing
Nothing -> Just <$> createUser email pass_hash displayName now
return $ case x of
(Left b) -> Left (DBError (pack . show $ b))
(Right (Left _)) -> Left UserExists
(Right (Right uuid)) ->
(Right Nothing) -> Left UserExists
(Right (Just uuid)) ->
Right $ User (PlayerId $ one uuid) (DisplayName displayName) email
(PassHash pass_hash) (Joined now) (LastLogin now)
type DBPlayer = (Text, Text, ByteString, UTCTime, UTCTime)
lookupPlayerById :: Pool -> PlayerId -> IO (Either APIError User)
lookupPlayerById sqlC (PlayerId pid') = do
x <- H.session sqlC $ H.tx serialR $ do
(exists :: Maybe DBPlayer) <- H.maybeEx $ [H.stmt|
SELECT t.display_name, t.email, t.password_hash, t.joined, t.last_login
FROM tas.player t
WHERE t.id = $pid'
|]
return exists
return $ case x of
(Left e) -> Left (DBError (pack . show $ e))
(Right Nothing) -> Left (NotFound pid')
(Right (Just (dname, email', phash', joined', lastLogin'))) ->
Right $ User (PlayerId pid') (DisplayName dname) (Email email')
(PassHash phash') (Joined joined') (LastLogin lastLogin')
findUserByEmail :: Email -> Tx (Maybe (One UUID))
findUserByEmail (Email email) =
H.maybeEx $ [H.stmt|
......
{-# LANGUAGE OverloadedStrings #-}
module API.Errors (
APIError(..),
ViewErrors(..)
......@@ -5,6 +6,7 @@ module API.Errors (
import Data.Aeson
import Data.Text
import Data.UUID
data APIError
= Unknown Text
......@@ -13,6 +15,8 @@ data APIError
| BadCredentials
| UserExists
| DBError Text
| BadRequest Text
| NotFound UUID
newtype ViewErrors = ViewErrors [APIError]
......@@ -35,6 +39,15 @@ instance ToJSON APIError where
object [ "type" .= ("user_exists" :: Text)
, "description" .= ("This email is already registered." :: Text)
]
toJSON (BadRequest desc) =
object [ "type" .= ("bad_request" :: Text)
, "description" .= desc
]
toJSON (NotFound id') =
object [ "type" .= ("not_found" :: Text)
, "id" .= toText id'
, "description" .= ("Entity not found" :: Text)
]
instance ToJSON ViewErrors where
toJSON (ViewErrors es) =
......
......@@ -7,6 +7,7 @@ import qualified Hasql.Postgres as HP
import qualified Database.Redis as R
import API.Controllers.Login
import API.Controllers.Players
import API.Controllers.Register
import API.Database.Common
import API.Logging (mkLog, Log)
......@@ -22,7 +23,7 @@ main = do
logger <- mkLog
runSpock 3000 $ spockT id $
do core sqlC redisC logger
players
players sqlC
games
runs
......@@ -31,9 +32,9 @@ core sqlC redisC logger =
do post "register" (registerUser sqlC logger)
post "login" (login sqlC redisC logger)
players :: SpockT IO ()
players =
do get ("players" <//> var) $ \x -> text x
players :: Pool -> SpockT IO ()
players sqlC =
do get ("players" <//> var) (\playerId -> viewPlayer sqlC playerId)
get "players" $ text ""
put ("players" <//> var <//> "profile") $ \x -> text x
delete ("players" <//> var) $ \x -> text x
......
......@@ -2,7 +2,7 @@
-- further documentation, see http://haskell.org/cabal/users-guide/
name: type-assisted-speed-runs
version: 0.3.0.0
version: 0.3.1.0
synopsis: A speed-run hosting site
homepage: https://gitlab.com/cpp.cabrera/type-assisted-speed-runs
-- description:
......@@ -30,6 +30,7 @@ library
exposed-modules:
API.Controllers.Common
, API.Controllers.Login
, API.Controllers.Players
, API.Controllers.Register
, API.Database.Common
, API.Database.User
......
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