diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# verify + +A module to verify CJ tokens diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/cj-token.cabal b/cj-token.cabal new file mode 100644 --- /dev/null +++ b/cj-token.cabal @@ -0,0 +1,68 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: cj-token +version: 0.0.0 +synopsis: A new Haskeleton package. +description: cj-token is a new Haskeleton package. +category: Other +maintainer: Author name here +license: ISC +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + package.yaml + README.md + stack.yaml + +library + hs-source-dirs: + library + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall + build-depends: + aeson < 2 + , base < 5 + , base64-bytestring < 2 + , containers < 1 + , either < 5 + , jwt < 1 + , text < 2 + , time < 2 + , text-conversions < 1 + exposed-modules: + CJ.Auth.Token + default-language: Haskell2010 + +executable cj-token + main-is: Main.hs + hs-source-dirs: + executable + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , cj-token + default-language: Haskell2010 + +test-suite cj-token-test-suite + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test-suite + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , jwt + , hspec + , time + , text + , text-conversions + , QuickCheck + , cj-token + other-modules: + CJ.Auth.TokenSpec + default-language: Haskell2010 diff --git a/executable/Main.hs b/executable/Main.hs new file mode 100644 --- /dev/null +++ b/executable/Main.hs @@ -0,0 +1,2 @@ +main :: IO () +main = return () diff --git a/library/CJ/Auth/Token.hs b/library/CJ/Auth/Token.hs new file mode 100644 --- /dev/null +++ b/library/CJ/Auth/Token.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module CJ.Auth.Token + ( UserBearerToken(..) + , JSONToken(..) + , decodeToken + , encodeToken + ) where + +import qualified Data.ByteString.Base64.URL as BS64 +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Web.JWT as JWT +import Control.Monad +import Data.Aeson (FromJSON (..), Value, toJSON) +import Data.Aeson.Types (parseMaybe) +import Data.Either.Combinators +import Data.Maybe +import Data.Time.Clock.POSIX (POSIXTime) +import Web.JWT + ( Algorithm(HS256) + , JWTClaimsSet(JWTClaimsSet) + , Secret + , claims + , decodeAndVerifySignature + , def + , encodeSigned + , numericDate + , secondsSinceEpoch + , unregisteredClaims + ) + +class JSONToken a where + toClaims :: a -> JWTClaimsSet + fromClaims :: JWTClaimsSet -> Maybe a + +data UserBearerToken = UserBearerToken + { _bearerUserId :: T.Text + , _bearerAppId :: T.Text + } deriving (Eq, Show) + +instance JSONToken UserBearerToken where + toClaims UserBearerToken{ _bearerUserId = uid, _bearerAppId = aid } = + def { unregisteredClaims = M.fromList [ ("userId", toJSON uid) + , ("appId", toJSON aid) ] } + + fromClaims JWTClaimsSet{ unregisteredClaims = clms } = + UserBearerToken <$> uid <*> aid + where uid = fromValue =<< M.lookup "userId" clms + aid = fromValue =<< M.lookup "appId" clms + + +fromValue :: FromJSON a => Value -> Maybe a +fromValue = parseMaybe parseJSON + +encodeJWT :: Secret -> JWTClaimsSet -> T.Text +encodeJWT = encodeSigned HS256 + +decodableToken :: T.Text -> Bool +decodableToken token = isJust $ do + (header : claimsPayload : _) <- return $ T.splitOn "." token + void $ verifyUtf8Base64 header + verifyUtf8Base64 claimsPayload + where + verifyUtf8Base64 base64Str = rightToMaybe $ TE.decodeUtf8' (BS64.decodeLenient $ TE.encodeUtf8 base64Str) + +encodeToken :: (JSONToken a) => Secret -> a -> POSIXTime -> T.Text +encodeToken secret token expTime = encodeJWT secret expiringClaims + where baseClaims = toClaims token + expiringClaims = baseClaims { JWT.exp = numericDate expTime } + +decodeToken :: (JSONToken a) => Secret -> T.Text -> POSIXTime -> Maybe a +decodeToken secret token currentTime = + fromClaims =<< verifyFresh currentTime =<< decodedClaims + where jwt = if decodableToken token then decodeAndVerifySignature secret token else Nothing + decodedClaims = claims <$> jwt + +verifyFresh :: POSIXTime -> JWTClaimsSet -> Maybe JWTClaimsSet +verifyFresh currentTime clms@JWTClaimsSet{ JWT.exp = (Just expirationTime) } + | secondsSinceEpoch expirationTime < currentTime = Nothing + | otherwise = Just clms +verifyFresh _ clms = Just clms diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,70 @@ +name: cj-token +version: 0.0.0 +category: Other +synopsis: A new Haskeleton package. +description: cj-token is a new Haskeleton package. +maintainer: Author name here +license: ISC +extra-source-files: +- package.yaml +- README.md +- stack.yaml +ghc-options: -Wall +default-extensions: +- ConstraintKinds +- DeriveGeneric +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- GADTs +- GeneralizedNewtypeDeriving +- KindSignatures +- LambdaCase +- MultiParamTypeClasses +- NamedFieldPuns +- OverloadedStrings +- RankNTypes +- ScopedTypeVariables +- TypeApplications +- TypeOperators +library: + dependencies: + - aeson < 2 + - base < 5 + - base64-bytestring < 2 + - containers < 1 + - either < 5 + - jwt < 1 + - text < 2 + - time < 2 + - text-conversions < 1 + source-dirs: library +executables: + cj-token: + dependencies: + - base + - cj-token + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + main: Main.hs + source-dirs: executable +tests: + cj-token-test-suite: + dependencies: + - base + - jwt + - hspec + - time + - text + - text-conversions + - QuickCheck + - cj-token + + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + main: Main.hs + source-dirs: test-suite diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,11 @@ + +resolver: lts-8.11 + +packages: +- '.' + +extra-deps: [] + +flags: {} + +extra-package-dbs: [] diff --git a/test-suite/CJ/Auth/TokenSpec.hs b/test-suite/CJ/Auth/TokenSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/CJ/Auth/TokenSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module CJ.Auth.TokenSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import qualified Web.JWT as JWT +import qualified Data.Text as T +import Data.String (fromString) +import CJ.Auth.Token + +instance Arbitrary T.Text where + arbitrary = fromString <$> arbitrary + +spec :: Spec +spec = do + describe "UserBearerToken" $ do + describe "encodeToken / decodeToken" $ + it "decode . encode = id" $ + property $ \x y -> + let token = UserBearerToken{ _bearerUserId = x + , _bearerAppId = y } + secret = JWT.secret "" + encoded = encodeToken secret token 100 + decoded = decodeToken secret encoded 0 + in decoded == Just token + + describe "decodeToken" $ + it "returns Nothing if the token is expired" $ + property $ \x y -> + let token = UserBearerToken{ _bearerUserId = x, _bearerAppId = y } + secret = JWT.secret "" + time = 0 + encoded = encodeToken secret token time + decoded = decodeToken secret encoded 100 :: (Maybe UserBearerToken) + in decoded `shouldBe` Nothing + + + describe "decodeToken" $ + it "returns Nothing if token is garbage" $ do + shouldBe (decodeToken (JWT.secret "secret") "" 123) (Nothing :: Maybe TClaim) + shouldBe (decodeToken (JWT.secret "secret") "xyz.abc.123" 123) (Nothing :: Maybe TClaim) + shouldBe (decodeToken (JWT.secret "secret") "ybGcJ9.eyJzWV9.TJVAFh7HgQ" 123) (Nothing :: Maybe TClaim) + shouldBe (decodeToken (JWT.secret "secret") "eyJvbmUiOiIxIiwiYWxnIjoiSFMyNTYifQ" 123) (Nothing :: Maybe TClaim) + shouldBe (decodeToken (JWT.secret "secret") "eyJvbmUiOiIxIiwiYWxnIjoiSFMyNTYifQ.eyJvbmUiOiIxIiwiYWxnIjoiSFMyNTYifQ" 123) (Nothing :: Maybe TClaim) + +data TClaim = TClaim + deriving (Eq, Show) + +instance JSONToken TClaim where + toClaims _ = JWT.def + fromClaims _ = Just TClaim diff --git a/test-suite/Main.hs b/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/test-suite/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}