ed66c43 · denis · git.iko.soy

git.iko.soy/denis

on master help sign in

Resolved #10.

ed66c43iko8 years ago

denis/docs/Docs.hs+9−3

compare with master

unifiedsplit

@@ -6,8 +6,6 @@

7import Server.API

8import Servant.Docs

9−import Servant.API

10−import Data.Post

11import qualified Data.Text as T

9import qualified Data.Text as T

12import Servant.Server

10import Servant.Server

13import Servant

11import Servant

@@ -20,13 +18,16 @@ import Data.Int (Int64)

20import Data.Word (Word64)

18import Data.Word (Word64)

21import Server.API.Posts

19import Server.API.Posts

22import Server.Logger

20import Server.Logger

21+import Server.Auth

24docsWriter :: HasDocs api => String -> Proxy api -> IO ()

23docsWriter :: HasDocs api => String -> Proxy api -> IO ()

25−docsWriter file = writeFile ("docs/" ++ file ++ ".md") . markdown . docs

24+docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs

27main = do

26main = do

28 docsWriter "posts" (Proxy :: Proxy ("posts" :> PostApi))

27 docsWriter "posts" (Proxy :: Proxy ("posts" :> PostApi))

29 docsWriter "all" serverProxy

28 docsWriter "all" serverProxy

29+ docsWriter "authentication" (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>

30+ Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))

31instance ToSample Char where

32instance ToSample Char where

32 toSamples _ = singleSample 'c'

33 toSamples _ = singleSample 'c'

@@ -39,3 +40,8 @@ instance ToSample Word64 where

40instance ToSample Log where

41instance ToSample Log where

41 toSamples _ = noSamples

42 toSamples _ = noSamples

43+

44+normalizer :: String -> String

45+normalizer (' ':' ':' ':' ':'`':'`':'`':xs) = "```" ++ normalizer xs

46+normalizer (x:xs) = x : normalizer xs

47+normalizer "" = ""

denis/src/Data/Connection.hs+9−1

@@ -13,7 +13,8 @@ module Data.Connection (

13 runQ',

14 runQnotFound,

15 runQerror,

16− maybeNotFound

16+ maybeNotFound,

17+ maybeInvalidToken

17) where

18) where

19import Squeal.PostgreSQL

20import Squeal.PostgreSQL

@@ -23,6 +24,7 @@ import Server.App

23import Control.Monad.Reader

24import Control.Monad.Reader

24import Control.Monad.Except

25import Control.Monad.Except

25import Servant.Server

26import Servant.Server

27+import Server.Error

27type StaticPQ = PoolPQ Schema Handler

29type StaticPQ = PoolPQ Schema Handler

@@ -43,3 +45,9 @@ maybeNotFound :: App (Maybe a) -> App a

43maybeNotFound = (>>= (\t -> case t of

45maybeNotFound = (>>= (\t -> case t of

44 Just y -> return y

46 Just y -> return y

45 Nothing -> throwError err404))

47 Nothing -> throwError err404))

48+

49+maybeInvalidToken :: App (Maybe a) -> App a

50+maybeInvalidToken = (>>= (\t -> case t of

51+ Just y -> return y

52+ Nothing -> throwError invalidToken))

53+

denis/src/Server/API.hs+8−5

@@ -9,7 +9,8 @@

9module Server.API (

10 API,

11 serverProxy,

12− mkServerAPI

12+ mkServerAPI,

13+ Authentication

13) where

14) where

15import Data.Proxy

16import Data.Proxy

@@ -30,7 +31,7 @@ import Control.Lens

31instance HasDocs api => HasDocs (Authentication :> api) where

32instance HasDocs api => HasDocs (Authentication :> api) where

32 docsFor Proxy (endpoint, action) =

33 docsFor Proxy (endpoint, action) =

33− docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `401 Unauthorized` if the cookies are invalid or don't premit access to the requested data."]])

34+ docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `498 Invalid Token` if the token is invalid or the token header is missing. Returns `401 Unathorized` if the token doesn't premit access to the requested data."]])

36-- MARK: Implementation

37-- MARK: Implementation

@@ -39,8 +40,9 @@ type Authentication = AuthProtect "basicAuth"

40type API =

41type API =

41 LoggerAPI :<|>

42 LoggerAPI :<|>

42− "authenticate" :> AuthenticationHandler :<|>

43+ "authentication" :> AuthenticationHandler :<|>

43− Authentication :> (

44+ Authentication :> (

45+ "authentication" :> "me" :> Post '[JSON] UserId :<|>

44 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>

46 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>

45 "posts" :> PostApi

47 "posts" :> PostApi

46 )

48 )

@@ -51,7 +53,8 @@ serverProxy = Proxy

51mkServerAPI :: Logger -> ServerT API App

53mkServerAPI :: Logger -> ServerT API App

52mkServerAPI l =

54mkServerAPI l =

53 l :<|>

55 l :<|>

54− authenticate :<|> (\uId ->

56+ authenticationAPI :<|> (\uId ->

57+ return uId :<|>

55 maybeNotFound . runQnotFound . getUsers :<|>

58 maybeNotFound . runQnotFound . getUsers :<|>

56 postApi uId

59 postApi uId

57 )

60 )

denis/src/Server/API/Posts.hs−1

@@ -20,7 +20,6 @@ import Servant.Server

20import Data.Query

21import Data.User

22import Data.Connection

23−import Servant

24import Data.Word (Word64)

23import Data.Word (Word64)

25import Servant.Docs (ToSample, toSamples, samples)

24import Servant.Docs (ToSample, toSamples, samples)

denis/src/Server/Auth.hs+31−15

@@ -14,9 +14,10 @@ module Server.Auth (

14 cookieTokenKey,

15 genAuthServerContext,

16 AuthenticationHandler,

17− authenticate,

17+ logIn,

18 contextProxy,

19− AuthenticationCredits(..)

19+ AuthenticationCredits(..),

20+ authenticationAPI

20) where

21) where

22import Server.App

23import Server.App

@@ -35,6 +36,7 @@ import Network.Wai (Request, requestHeaders)

35import Servant.Server

36import Servant.Server

36import Web.Cookie

37import Web.Cookie

37import Data.Time.Clock

38import Data.Time.Clock

39+import Data.Time.Calendar

38import Data.Proxy

40import Data.Proxy

39import qualified GHC.Generics as GHC

41import qualified GHC.Generics as GHC

40import Data.Aeson

42import Data.Aeson

@@ -48,27 +50,41 @@ instance ToSample AuthenticationCredits where

49-- MARK: Implementation

51-- MARK: Implementation

53+type AuthenticationHandler =

54+ "login" :>

55+ ReqBody '[JSON] AuthenticationCredits :>

56+ Post '[JSON] (Headers '[Header "Set-Cookie" String] UserId) :<|>

57+ "logout" :>

51−type AuthenticationHandler = ReqBody '[JSON] AuthenticationCredits :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)

58+ PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)

53−data AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}

60+newtype AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}

54 deriving GHC.Generic

61 deriving GHC.Generic

56instance ToJSON AuthenticationCredits

63instance ToJSON AuthenticationCredits

57instance FromJSON AuthenticationCredits

64instance FromJSON AuthenticationCredits

59−authenticate :: ServerT AuthenticationHandler App

66+authenticationAPI :: ServerT AuthenticationHandler App

67+authenticationAPI = logIn :<|> logOut

68+

69+logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserId)

60−authenticate (AuthenticationCredits uId) = do

70+logIn (AuthenticationCredits uId) = do

61 expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days

71 expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days

62− tId <- fmap userId . runQ invalidToken . getUser $ uId

72+ tId <- fmap userId . runQ err404 . getUser $ uId

63 let cookie = defaultSetCookie {

73 let cookie = defaultSetCookie {

64 setCookieName = cookieTokenKey,

74 setCookieName = cookieTokenKey,

65 setCookieValue = C.pack $ show tId,

75 setCookieValue = C.pack $ show tId,

66 setCookieExpires = Just expire,

76 setCookieExpires = Just expire,

67− -- setCookieDomain = Just "127.0.0.1",

68 setCookiePath = Just "/" }

77 setCookiePath = Just "/" }

69− -- let token = cookieTokenKeyString <> "=" <> show tId <> "; Expires=" <> show expire <> "; Domain=127.0.0.1:2000; Path=/" -- ; Secure" --; HttpOnly"

70− return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent

78+ return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) tId

80+logOut :: App (Headers '[Header "Set-Cookie" String] NoContent)

81+logOut =

82+ let cookie = defaultSetCookie {

83+ setCookieName = cookieTokenKey,

84+ setCookieValue = "invalid",

85+ setCookieExpires = Just (UTCTime (ModifiedJulianDay 0) 0),

86+ setCookiePath = Just "/" }

87+ in return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent

73checkToken :: DBConnection -> BS.ByteString -> Handler UserId

89checkToken :: DBConnection -> BS.ByteString -> Handler UserId

74checkToken conn token = do

90checkToken conn token = do

@@ -80,11 +96,11 @@ checkToken conn token = do

80authHandler :: DBConnection -> AuthHandler Request UserId

96authHandler :: DBConnection -> AuthHandler Request UserId

81authHandler conn = mkAuthHandler handler

97authHandler conn = mkAuthHandler handler

82 where

98 where

83− maybeToEither e = maybe (Left e) Right

99+ maybeToEither = maybe (Left ()) Right

84− throw401 msg = throwError $ err401 { errBody = msg }

100+ throw = const $ throwError invalidToken

85− handler req = either throw401 (checkToken conn) $ do

101+ handler req = either throw (checkToken conn) $ do

86− cookie <- maybeToEither "Missing cookie header" $ lookup "cookie" $ requestHeaders req

102+ cookie <- maybeToEither $ lookup "cookie" $ requestHeaders req

87− maybeToEither "Missing token in cookie" $ lookup cookieTokenKey $ parseCookies cookie

103+ maybeToEither $ lookup cookieTokenKey $ parseCookies cookie

104

89cookieTokenKey :: BS.ByteString

105cookieTokenKey :: BS.ByteString

90cookieTokenKey = "servant-auth-cookie"

106cookieTokenKey = "servant-auth-cookie"

denis/src/Server/Error.hs+1−1

@@ -8,7 +8,7 @@ import Servant.Server

9invalidToken :: ServantErr

10invalidToken = ServantErr {

11− errHTTPCode = 401,

11+ errHTTPCode = 498,

12 errReasonPhrase = "Invalid Token",

13 errBody = "The supplied token is invalid",

14 errHeaders = []