Chapter 2 - Supporting Libraries and Authorization

By John Lenz. 2016.

The design of the full-stack Haskell website has two supporting libraries. First, there is a library which is shared between the client and server and contains the domain datatypes and network API. Second, there is a library which contains the database and authentication operations used by the server.

domain-data library

The domain-data library contains the types shared between the client and server, business logic, and some utility functions that transform this data. Since this library is shared between GHCJS and GHC, I keep the dependencies small (for example, I use microlens instead of the full lens library).

In addition, this library depends on servant and contains the network API definitions. Unlike many of the servant examples, I like to give each route its own name with the full path and then group the routes by similar functionality before combining them together into the final full API type.

type GetTeamRoute = "team" :> Capture "teamkey" TeamKey :> Get '[JSON] Team
type CreateTeamRoute = "teams" :> ReqBody '[JSON] Team :> Post '[JSON] ()
type UpdateTeamRoute = "team" :> Capture "teamkey" TeamKey :> ReqBody '[JSON] Team :> Put '[JSON] ()
type GetAllTeamsRoute = "teams" :> Get '[JSON] (Vector Team)

type TeamAPI = GetTeamRoute :<|> CreateTeamRoute :<|> UpdateTeamRoute :<|> GetAllTeamsRoute

...

type MyAPI = TeamAPI :<|> UserAPI :<|> ...

Authentication

I use JSON Web Tokens for authentication. JavaScript is required for the user interface which allows JavaScript to easily manage the web token using local storage. A cookie-based authentication scheme introduces complexity with cross-site request forgery attack prevention and complicates the server code.

The domain-data library contains the types and routes for authentication, while the actual authentication occurs inside the server code, not in domain-data. Servant has some support for authentication and there is now servant-auth-token but I am not using it (mainly because servant-auth-token came out after I had already implemented the authentication). First, I represent users via a UserCredentials structure and wrap that up into a Token structure to capture all data stored in the JSON web token.

-- | User credentials extracted from the JWT token
data UserCredentials = UserCredentials {
    _credId :: UserId
  , _credEmail :: Text
  , _credEmailVerified :: Bool
} deriving (Show, Generic)

makeLenses ''UserCredentials

-- | There are two kinds of tokens.  When reseting the password, we send
-- a token via email.  When a user logs in, we send a token to the browser.
data TokenAudience = TokenSentViaEmail | TokenSentToBrowser
    deriving (Show, Eq, Generic)

-- | The contents of the Jwt token is an encoding of this structure.
data Token = Token {
    _tokenCreds :: UserCredentials
  , _issuedP :: POSIXTime
  , _expiredP :: POSIXTime
  , _jwtAudience :: TokenAudience
} deriving (Show, Eq, Generic)

makeLenses ''Token

instance Aeson.FromJSON Token where
    parseJSON = Aeson.withObject "web token" $ \o -> do
        aud :: Text <- o .: "aud"
        aud' <- case aud of
                    "mycompany:email" -> pure TokenSentViaEmail
                    "mycompany:web" -> pure TokenSentToBrowser
                    _ -> fail "Invalid audience for token"
        Token <$> (UserCredentials <$> o .: "sub" <*> o .: "email" <*> o .: "email_verified")
              <*> (fromInteger <$> o .: "iat")
              <*> (fromInteger <$> o .: "exp")
              <*> pure aud'

instance Aeson.ToJSON Token where
    toJSON (Token ucreds i e a) = Aeson.object
        [ "sub" .= (ucreds^.credId), "email" .= (ucreds^.credEmail), "email_verified" .= (ucreds^.credEmailVerified)
        , "iat" .= (round i :: Int64)
        , "exp" .= (round e :: Int64)
        , "aud" .= case a of
                    TokenSentViaEmail -> asText "mycompany:email"
                    TokenSentToBrowser -> asText "mycompany:web"
        ]

The token is sent via the Authorization header. I look for the header on all routes, even those for which authentication is not required. See the server design for details on how the header is handled.

newtype UnverifiedJwtToken = UnverifiedJwtToken Text
  deriving (Show, FromHttpApiData)
type JwtAuthHeader = Header "authorization" UnverifiedJwtToken
type MyAPIWithAuth = JwtAuthHeader :> MyAPI

Finally, the domain-data library has a small test suite built with hspec.

Datastorage

The datastorage library contains the database actions and authorization code (deciding which users can access which resource). The reason for separating this into its own library is unit testing. For the most part, Haskell code needs some but does not need a lot of unit testing (the domain-data unit test is quite small). Database and authorization code is the exception. I am using persistent, but the design works with any of Haskell's database and datastorage tools.

One key design question is if the same types from the network API in domain-data are also used for the database. Some types like User must differ between the database and the network API because in the database you need to store the hashed password and so on. For other types, I decide on a case-by-case basis. If no processing happens on the server and the data is just passed back and forth to the client, I reuse the type from the design-data library. If some processing occurs on the server or if some operation operates on only a subset of the data, I create a new data type in the datastorage library and write conversion functions between the type in domain-data used for the network API and the type in datastorage used for the database.

The datastorage library then consists of functions which first perform authorization and then access the database; a UserCredentials structure is passed to each function. For example, using persistent,

isMemberOfTeam :: UserCredentials -> Team -> Bool
user `isMemberOfTeam` team = {- implementation here -}

loadTeam :: UserCredentials -> TeamKey -> SqlPersistM Team
loadTeam ucreds teamkey = do
    mteam <- get teamkey
    case mteam of
        Nothing -> throwM DocumentNotFound
        Just t | ucreds `isMemberOfTeam` t -> return t
               | otherwise -> throwM Unauthorized

Similar functions exist for updating the team (which checks if the user is a team administrator), deleting teams, querying teams, and so on.

Test Suite

The datastorage library contains a large test suite in hspec. To easily test all combinations of users, permissions, and operations, the test suite is built around a free monad. The free monad is built with the free package, and contains operations for creating the various resources and then expectations of success or failure to access those resources. One advantage of using a DSL is that it can also be re-used to test the server via HTTP requests (explained in a later chapter).

data TestDSL next = CreateUser (UserCredentials -> next)
                  | CreateTeam (TeamKey -> next)
                  | AddUserToTeam TeamKey UserCredentials MembershipLevel next
                  | ExpectSucceedViewTeam TeamKey UserCredentials next
                  | ExpectFailViewTeam TeamKey UserCredentials next
                  ....
    deriving Functor

createUser :: Free TestDSL UserCredentials
createUser = liftF $ CreateUser id

createTeam :: Free TestDSL TeamKey
createTeam = liftF $ CreateTeam id

addUserToTeam :: TeamKey -> UserCredentials -> MembershipLevel -> Free TestDSL ()
addUserToTeam k u m = liftF $ AddUserToTeam k u m ()

...

The main advantage of using such a DSL is the tests can be written in the DSL and therefore focus on the operations and if they should succeed or fail, without getting too involved in the gory details. For example, the interpreter for CreateTeam randomly fills in the team name and then checks it inside ExpectSucceedViewTeam, but the tests written in the DSL avoid this detail. This provides a focus for the tests and makes them easier to audit to make sure the various permissions are being correctly tested.

To write the tests in the DSL, I use a writer monad to create a list of specs .

it :: String -> Free TestDSL () -> Writer [(String, Free TestDSL ())]
it n f = tell [(n, f)]

testDSL :: [(String, Free TestDSL ())]
testDSL = snd $ runWriter $ do
    it "allows a team administrator to access a team" $ do
        u <- createUser
        t <- createTeam
        addUserToTeam u t Administrator
        expectSucceedViewTeam u t
        expectSucceedEditTeam u t

    it "denies a non-team member from accessing a team" $ do
        u <- createUser
        t <- createTeam
        expectFailViewTeam u t

    ....

Since these tests are in a monad, I use mapM to iterate through various possible team membership levels and can therefore make sure users are correctly allowed or denied access to resources for all possibile membership levels.

For the DSL interpreter, I use a StateT transformer to keep the expected values of the various resources.

data TestState = TestState
   { _testTeams :: HashMap TeamKey Team
   , ....
   }
makeLenses ''TestState

type TestT a = StateT TestState SqlPersistM a

runAction :: TestDSL (TestT ()) -> TestT ()
runAction (CreateTeam continue) = do
    team <- {- randomly create a team -}
    key <- lift $ insert team -- insert is from persistent
    (testTeams . at key) .= Just team
    continue key
...

runDSL :: Free TestDSL () -> SqlPersistM ()
runDSL free = flip evalStateT (TestState mempty) $
    iterM runAction free

Finally, I turn the examples defined in the DSL into an actual hspec spec.

spec :: Test.Hspec.SpecWith SqlBackend
spec = Test.Hspec.describe "DSL spec" $
    forM_ testDSL $ \(name, free) ->
        Test.Hspec.it name $ \backend ->
            runSqlPersistM (runDSL free) backend