cj-token (empty) → 0.0.0

raw patch · 9 files changed

+299/−0 lines, 9 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, base64-bytestring, cj-token, containers, either, hspec, jwt, text, text-conversions, time

Files

• README.md +3/−0
• Setup.hs +6/−0
• cj-token.cabal +68/−0
• executable/Main.hs +2/−0
• library/CJ/Auth/Token.hs +82/−0
• package.yaml +70/−0
• stack.yaml +11/−0
• test-suite/CJ/Auth/TokenSpec.hs +56/−0
• test-suite/Main.hs +1/−0

@@ -0,0 +1,3 @@+# verify++A module to verify CJ tokens

@@ -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: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple+main :: IO ()+main = Distribution.Simple.defaultMain

@@ -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

@@ -0,0 +1,2 @@+main :: IO ()+main = return ()

@@ -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

@@ -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

@@ -0,0 +1,11 @@++resolver: lts-8.11++packages:+- '.'++extra-deps: []++flags: {}++extra-package-dbs: []

@@ -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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}