Commit 088b57a6 authored by Allele Dev's avatar Allele Dev

add: login, registration, routes, redis, psql

* Add support for user registration
* Add support for logins and sessions
* Update DB model:
  * no longer have separate user_name field
  * change type of password_hash from varbit -> bytea
* Create initial route skeleton
* Add support for informative error handling
* Create User JSON response view
parent 22daccf3
.stack-work
dist
dump.rdb
# 0.2.0.0 (Sep. 23, 2015)
* Add support for user registration
* Add support for logins and sessions
* Update DB model:
* no longer have separate user_name field
* change type of password_hash from varbit -> bytea
* Create initial route skeleton
* Add support for informative error handling
* Create User JSON response view
# 0.1.0.0 (Sep. 20, 2015)
* Initial commit
# Endpoints
This document serves as an overview of the endpoints this application
supports.
## Synopsis
```
-- core
POST /register?email=...&password=...
POST /login
Authorization: Basic:base64(user:password)
-- players
GET /players
GET /players/:id
DELETE /players/:id
-- profile management
GET /profiles/:id
PUT /profiles/:id -- bio, display name, password
POST /profiles/:id/image
-- images
GET /images/:id
DELETE /images/:id
-- games
POST /games -- admin
GET /games
GET /games/:id
PUT /games/:id -- admin
DELETE /games/:id -- admin
-- runs
GET /runs
GET /runs/:id
POST /runs/:id/archive
GET /games/:id/runs
-- player runs
GET /players/:id/runs
-- game runs
GET /games/:id/runs
POST /games/:id/runs
```
CREATE EXTENSION IF NOT EXISTS "uuid-ossp";
CREATE SCHEMA IF NOT EXISTS tas;
CREATE SCHEMA IF NOT EXISTS tas AUTHORIZATION strangeloop;
CREATE TABLE IF NOT EXISTS tas.image (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
......@@ -11,9 +11,8 @@ CREATE TABLE IF NOT EXISTS tas.image (
CREATE TABLE IF NOT EXISTS tas.player (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
display_name varchar(64) NOT NULL,
user_name varchar(64) NOT NULL,
email varchar(254) NOT NULL,
password_hash varbit(512) NOT NULL,
password_hash bytea NOT NULL,
joined timestamptz NOT NULL,
last_login timestamptz NOT NULL,
UNIQUE (email)
......@@ -36,8 +35,8 @@ CREATE TABLE IF NOT EXISTS tas.run (
);
CREATE TABLE IF NOT EXISTS tas.run_archive (
run_id NOT NULL REFERENCES tas.run (id),
player_id NOT NULL REFERENCES tas.player (id),
run_id uuid NOT NULL REFERENCES tas.run (id),
player_id uuid NOT NULL REFERENCES tas.player (id)
);
CREATE TABLE IF NOT EXISTS tas.game (
......@@ -62,3 +61,7 @@ CREATE TABLE IF NOT EXISTS tas.player_games (
player_id uuid NOT NULL REFERENCES tas.player (id),
game_id uuid NOT NULL REFERENCES tas.game (id)
);
GRANT SELECT, INSERT, UPDATE, DELETE
ON ALL TABLES IN SCHEMA tas
TO strangeloop;
module API.Controllers.Common (
getSessionKey,
setSessionKey,
ok,
created,
noContent,
redirect,
notModified,
errorResponse
) where
import Control.Monad.IO.Class
import Data.Aeson (ToJSON)
import Data.UUID (UUID, toText)
import Data.Text (Text)
import Web.Spock.Shared
import qualified Network.HTTP.Types.Status as HTTP
import API.Errors
setSessionKey :: MonadIO m => UUID -> ActionT m ()
setSessionKey skey =
setCookie "SessionKey" (toText skey) 120000
getSessionKey :: MonadIO m => ActionT m (Maybe Text)
getSessionKey = cookie "SessionKey"
ok :: (ToJSON a, MonadIO m) => a -> ActionT m b
ok a = setStatus HTTP.status200 >> json a
created :: (ToJSON a, MonadIO m) => a -> ActionT m b
created a = setStatus HTTP.status201 >> json a
noContent :: MonadIO m => ActionT m ()
noContent = setStatus HTTP.status204
notModified :: MonadIO m => ActionT m ()
notModified = setStatus HTTP.status304
badRequest :: (ToJSON a, MonadIO m) => a -> ActionT m b
badRequest e = setStatus HTTP.status400 >> json e
unauthorized :: (ToJSON a, MonadIO m) => a -> ActionT m b
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
serverError :: (ToJSON a, MonadIO m) => a -> ActionT m b
serverError e = setStatus HTTP.status500 >> json e
-}
unavailable :: (ToJSON a, MonadIO m) => a -> ActionT m b
unavailable e = setStatus HTTP.status503 >> json e
errorResponse :: (MonadIO m) => APIError -> ActionT m a
errorResponse e@(Unknown _) = badRequest e
errorResponse e@AuthenticationDown = unavailable e
errorResponse e@Unauthorized = unauthorized e
errorResponse e@BadCredentials = forbidden e
errorResponse e@UserExists = badRequest e
errorResponse e@(DBError _) = badRequest e
{-# LANGUAGE FlexibleContexts #-}
module API.Controllers.Login (
login,
endSession
-- logout
) where
import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Text
import Data.Text.Encoding (encodeUtf8)
import Data.UUID (toASCIIBytes, UUID)
import Data.UUID.V4 (nextRandom)
import Database.Redis (runRedis)
import Web.Spock
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text.Encoding as T
import qualified Database.Redis as R
import API.Controllers.Common
import API.Database.Common
import API.Errors
import API.Models.Common
import qualified API.Database.User as DB
data SessionCheck
= ValidSession
| InvalidSession
data AuthCheck
= AuthOkay Email Pass
| AuthInvalid
| AuthError
| AuthMissing
login :: Pool -> R.Connection -> ActionT IO ()
login sqlC redisC = do
auth <- header "Authorization"
ret <- checkSession redisC
case ret of
ValidSession -> noContent
InvalidSession -> do
auth' <- liftIO $ checkAuth sqlC auth
case auth' of
AuthError -> errorResponse AuthenticationDown
(AuthOkay _ _) -> do
skey <- liftIO $ makeSession redisC
setSessionKey skey
noContent
AuthMissing -> errorResponse Unauthorized
AuthInvalid -> errorResponse BadCredentials
checkAuth :: Pool -> Maybe Text -> IO AuthCheck
checkAuth sqlC (Just k) =
case parseBasicAuth k of
AuthOkay n p -> do
ret <- DB.authenticate sqlC n p
return $ case ret of
Right DB.AuthSuccess -> AuthOkay n p
Right DB.AuthFailed -> AuthInvalid
Left _ -> AuthError
e -> return e
checkAuth _ Nothing = return AuthMissing
checkSession :: R.Connection -> ActionT IO SessionCheck
checkSession redisC = do
key <- getSessionKey
case key of
Nothing -> return InvalidSession
(Just k) -> do
ret <- liftIO $ runRedis redisC (R.exists (encodeUtf8 k))
return $ case ret of
(Right True) -> ValidSession
_ -> InvalidSession
endSession :: R.Connection -> Text -> IO ()
endSession redisC key =
let k = [encodeUtf8 key]
in void (runRedis redisC (R.del k))
makeSession :: R.Connection -> IO UUID
makeSession redisC = do
u <- nextRandom
-- TODO: log the status for this call
let key = toASCIIBytes u
_ <- runRedis redisC (R.set key "" >> R.expire key 1200)
return u
parseBasicAuth :: Text -> AuthCheck
parseBasicAuth authH =
case splitOn "Basic: " authH of
["", k] -> parseAuth k
_ -> AuthInvalid
where parseAuth k =
let k' = B64.decode (T.encodeUtf8 k)
in case fmap (splitOn ":" . T.decodeUtf8) k' of
Left _ -> AuthInvalid
Right ["",_] -> AuthInvalid
Right [_,""] -> AuthInvalid
Right [n,p] -> AuthOkay (Email n) (Pass p)
Right _ -> AuthInvalid
module API.Controllers.Register (
registerUser
) where
import Control.Monad.IO.Class
import Web.Spock.Shared
import API.Models.Common
import API.Controllers.Common
import API.Database.Common
import API.Responses.User
import qualified API.Database.User as DB
registerUser :: MonadIO m => Pool -> ActionT m b
registerUser sqlC = 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)
{-# LANGUAGE FlexibleContexts, ConstraintKinds, RankNTypes #-}
module API.Database.Common (
Cx,
Tx,
Val,
Row,
Pool,
SQLError,
One,
one,
serialW,
serialR
) where
import Data.Functor.Identity
import qualified Hasql as H
import qualified Hasql.Backend as HB
import qualified Hasql.Postgres as HP
type Cx = HB.CxTx HP.Postgres
type Tx a = forall s. H.Tx HP.Postgres s a
type Val t = HB.CxValue HP.Postgres t
type Row t = H.CxRow HP.Postgres t
type Pool = H.Pool HP.Postgres
type SQLError = H.SessionError HP.Postgres
type One = Identity
serialW :: Maybe (HB.TxIsolationLevel, Maybe Bool)
serialW = Just (H.Serializable, Just True)
serialR :: Maybe (HB.TxIsolationLevel, Maybe Bool)
serialR = Just (H.Serializable, Nothing)
one :: Identity a -> a
one (Identity a) = a
{-# LANGUAGE FlexibleContexts, QuasiQuotes, RankNTypes, ConstraintKinds #-}
module API.Database.User (
authenticate,
register,
findUserByEmail,
createUser,
AuthOutcome(..)
) where
import Data.UUID
import Data.ByteString (ByteString)
import Data.Monoid
import Data.Text (Text, pack)
import Data.Time.Clock
import System.Entropy
import qualified Hasql as H
import qualified Data.ByteString.Base16 as B16
import qualified Data.Text.Encoding as T
import API.Database.Common
import API.Errors
import API.Models.Common
import API.Models.User hiding (email)
data AuthOutcome
= AuthSuccess
| AuthFailed
-- | Authenticates a user.
authenticate :: (Cx, Val Text, Val ByteString) =>
Pool -> Email -> Pass -> IO (Either APIError AuthOutcome)
authenticate sqlC (Email email) (Pass pass) = do
let pass_hash = T.encodeUtf8 pass
-- transaction: lookup a user in the DB with these credentials
ret <- H.session sqlC $ H.tx serialR $ do
(v :: Maybe (One UUID)) <- H.maybeEx $ [H.stmt|
SELECT t.id
FROM tas.player t
WHERE t.email = $email
AND t.password_hash = $pass_hash
|]
return v
return $ case ret of
(Left e) -> Left (DBError (pack . show $ e))
(Right Nothing) -> Right AuthFailed
(Right (Just _)) -> Right AuthSuccess
-- | Register a user, if they don't already exist
register :: Pool -> Email -> Pass -> IO (Either APIError User)
register sqlC email (Pass pass) = do
let pass_hash = T.encodeUtf8 pass
now <- getCurrentTime
rand <- getEntropy 8
let randAppend = T.decodeUtf8 . B16.encode $ rand
let displayName = "runner" <> randAppend
-- transaction: register a user if the email isn't in the DB
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
return $ case x of
(Left b) -> Left (DBError (pack . show $ b))
(Right (Left _)) -> Left UserExists
(Right (Right uuid)) ->
Right $ User (PlayerId $ one uuid) (DisplayName displayName) email
(PassHash pass_hash) (Joined now) (LastLogin now)
findUserByEmail :: Email -> Tx (Maybe (One UUID))
findUserByEmail (Email email) =
H.maybeEx $ [H.stmt|
SELECT tas.player.id
FROM tas.player
WHERE tas.player.email = $email
|]
createUser :: Email -> ByteString -> Text -> UTCTime
-> Tx (One UUID)
createUser (Email email) pass_hash dname now =
H.singleEx $ [H.stmt|
INSERT INTO tas.player (display_name, email,
password_hash, joined, last_login)
VALUES ($dname, $email,
$pass_hash, $now, $now)
RETURNING tas.player.id
|]
module API.Errors (
APIError(..),
ViewErrors(..)
) where
import Data.Aeson
import Data.Text
data APIError
= Unknown Text
| AuthenticationDown
| Unauthorized
| BadCredentials
| UserExists
| DBError Text
newtype ViewErrors = ViewErrors [APIError]
instance ToJSON APIError where
toJSON (Unknown t) =
object [ "type" .= ("unknown" :: Text)
, "description" .= t
]
toJSON AuthenticationDown =
object [ "type" .= ("authentication_down" :: Text) ]
toJSON Unauthorized =
object [ "type" .= ("unauthorized" :: Text) ]
toJSON BadCredentials =
object [ "type" .= ("incorrect_credentials" :: Text) ]
toJSON (DBError t) =
object [ "type" .= ("database_error" :: Text)
, "description" .= t
]
toJSON UserExists =
object [ "type" .= ("user_exists" :: Text)
, "description" .= ("This email is already registered." :: Text)
]
instance ToJSON ViewErrors where
toJSON (ViewErrors es) =
object [ "errors" .= toJSON es ]
module API.Models.Common (
PlayerId(..),
RunId(..),
GameId(..),
DisplayName(..),
Joined(..),
LastLogin(..),
Email(..),
Pass(..),
PassHash(..),
hashPass
) where
import Data.UUID
import Data.ByteString
import Data.Text
import Data.Time.Clock
import Data.Text.Encoding (encodeUtf8)
newtype PlayerId = PlayerId UUID
newtype RunId = RunId UUID
newtype GameId = GameId UUID
newtype DisplayName = DisplayName Text
newtype Joined = Joined UTCTime
newtype LastLogin = LastLogin UTCTime
newtype Email = Email Text
newtype Pass = Pass Text
newtype PassHash = PassHash ByteString
hashPass :: Pass -> PassHash
hashPass (Pass t) = PassHash (encodeUtf8 t)
module API.Models.User (
User(..)
) where
import API.Models.Common
data User
= User { pid :: PlayerId
, name :: DisplayName
, email :: Email
, phash :: PassHash
, joined :: Joined
, lastLogin :: LastLogin
}
module API.Responses.User (
ViewUser(..)
) where
import Data.Aeson
import Data.UUID
import API.Models.Common
import API.Models.User
newtype ViewUser = ViewUser User
instance ToJSON ViewUser where
toJSON (ViewUser u) =
let (Email email') = email u
(PlayerId id') = pid u
(DisplayName name') = name u
(Joined joined') = joined u
(LastLogin login') = lastLogin u
in object [ "id" .= toText id'
, "email" .= email'
, "display_name" .= name'
, "joined" .= toJSON joined'
, "last_login" .= toJSON login'
]
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module API.Routes where
import Web.Spock.Safe
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
--------------------------------------------------------------------------------
main :: IO ()
main = do
let psqlConf = HP.ParamSettings "localhost" 5432 "strangeloop" "cat" "strangeloop"
let poolConf = maybe (error "Bad pool settings") id $ H.poolSettings 6 30
sqlC :: Pool
<- H.acquirePool psqlConf poolConf
redisC <- R.connect R.defaultConnectInfo
runSpock 3000 $ spockT id $
do core sqlC redisC
players
games
runs
core :: Pool -> R.Connection -> SpockT IO ()
core sqlC redisC =
do post "register" (registerUser sqlC)
post "login" (login sqlC redisC)
players :: SpockT IO ()
players =
do get ("players" <//> var) $ \x -> text x
get "players" $ text ""
put ("players" <//> var <//> "profile") $ \x -> text x
delete ("players" <//> var) $ \x -> text x
games :: SpockT IO ()
games =
do get "games" $ text ""
get ("games" <//> var) $ \x -> text x
runs :: SpockT IO ()
runs =
do get "runs" (text "")
post ("games" <//> var <//> "runs") $ \x -> text x
get ("runs" <//> var) $ \x -> text x
--------------------------------------------------------------------------------
......@@ -2,7 +2,7 @@
-- further documentation, see http://haskell.org/cabal/users-guide/
name: type-assisted-speed-runs
version: 0.1.0.0
version: 0.2.0.0
synopsis: A speed-run hosting site
homepage: https://gitlab.com/cpp.cabrera/type-assisted-speed-runs
-- description:
......@@ -27,27 +27,45 @@ source-repository head
location: git clone git://gitlab.com/cpp.cabrera/type-assisted-speed-runs.git
library
exposed-modules: API.Models
exposed-modules:
API.Controllers.Common
, API.Controllers.Login
, API.Controllers.Register
, API.Database.Common
, API.Database.User
, API.Errors
, API.Models
, API.Models.Common
, API.Models.User
, API.Responses.User
, API.Routes
build-depends: base >=4.8 && <4.9
, Spock
, aeson
, base16-bytestring
, base64-bytestring
, bytestring
, containers
, cryptohash
, entropy
, fast-logger
, free
, hasql
, hasql-backend
, hasql-postgres
, hedis
, http-types
, monad-control
, network
, network-uri
, text
, time
, transformers
, uuid
, wai
, wai-extra
default-extensions: OverloadedStrings, ScopedTypeVariables
hs-source-dirs: src
ghc-options: -Wall
default-language: Haskell2010
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