ProtocolSpec.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}

module Test.Method.ProtocolSpec where

import RIO (ByteString, Text, void)
import Test.Hspec
  ( Spec,
    anyErrorCall,
    before,
    context,
    describe,
    it,
    shouldReturn,
    shouldThrow,
  )
import Test.Method.Protocol
  ( ProtocolM,
    decl,
    dependsOn,
    lookupMock,
    protocol,
    thenReturn,
    verify,
    whenArgs,
  )

data Methods m where
  FindUser :: Methods (UserName -> IO (Maybe User))
  FindPassword :: Methods (UserName -> IO (Maybe HashedPassword))
  CreateUser :: Methods (UserName -> IO User)
  HashPassword :: Methods (PlainPassword -> IO HashedPassword)
  UpsertAuth :: Methods (UserId -> HashedPassword -> IO ())

data Service = Service
  { findUser :: UserName -> IO (Maybe User),
    findPassword :: UserName -> IO (Maybe HashedPassword),
    createUser :: UserName -> IO User,
    hashPassword :: PlainPassword -> IO HashedPassword,
    upsertAuth :: UserId -> HashedPassword -> IO ()
  }

doService :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doService Service {..} usernm passwd = do
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      hpasswd <- hashPassword passwd
      user <- createUser usernm
      upsertAuth (userId user) hpasswd
      pure $ Just user

doServiceHashFirst :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doServiceHashFirst Service {..} usernm passwd = do
  hpasswd <- hashPassword passwd
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      user <- createUser usernm
      upsertAuth (userId user) hpasswd
      pure $ Just user

doServiceWrongArgument :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doServiceWrongArgument Service {..} usernm passwd = do
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      _ <- hashPassword passwd
      user <- createUser usernm
      upsertAuth (userId user) passwd
      pure $ Just user

doServiceWrongExtraCalls :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doServiceWrongExtraCalls Service {..} usernm passwd = do
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      hpasswd <- hashPassword passwd
      hpasswd' <- hashPassword hpasswd
      user <- createUser usernm
      upsertAuth (userId user) hpasswd'
      pure $ Just user

doServiceWrongMissingCalls :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doServiceWrongMissingCalls Service {..} usernm passwd = do
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      _ <- hashPassword passwd
      user <- createUser usernm
      pure $ Just user

doServiceWrongOrder :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doServiceWrongOrder Service {..} usernm passwd = do
  user <- createUser usernm
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      hpasswd <- hashPassword passwd
      upsertAuth (userId user) hpasswd
      pure $ Just user

doServiceWrongUnspecifiedMethod :: Service -> UserName -> PlainPassword -> IO (Maybe User)
doServiceWrongUnspecifiedMethod Service {..} usernm _passwd = do
  mUser <- findUser usernm
  case mUser of
    Just _ -> pure Nothing
    Nothing -> do
      Just hpasswd <- findPassword usernm
      user <- createUser usernm
      upsertAuth (userId user) hpasswd
      pure $ Just user

serviceProtocol :: UserName -> PlainPassword -> HashedPassword -> UserId -> ProtocolM Methods ()
serviceProtocol usernm passwd hpasswd userid = do
  i1 <- decl $ whenArgs FindUser (== usernm) `thenReturn` Nothing
  i2 <- decl $ whenArgs CreateUser (== usernm) `thenReturn` User usernm userid `dependsOn` [i1]
  i3 <- decl $ whenArgs HashPassword (== passwd) `thenReturn` hpasswd
  void $ decl $ whenArgs UpsertAuth ((== userid), (== hpasswd)) `thenReturn` () `dependsOn` [i2, i3]

deriving instance (Show (Methods m))

deriving instance (Eq (Methods m))

deriving instance (Ord (Methods m))

type UserName = Text

type PlainPassword = ByteString

type HashedPassword = ByteString

type UserId = Int

data Env = Env

data User = User {userName :: UserName, userId :: UserId}
  deriving (Eq, Ord, Show)

spec :: Spec
spec = describe "protocol" $ do
  let usernm = "user1"
      passwd = "password1"
      hpasswd = "hashed_password1"
      userid = 0
  let setup = do
        penv <- protocol $ serviceProtocol usernm passwd hpasswd userid
        pure
          ( penv,
            Service
              { findUser = lookupMock FindUser penv,
                findPassword = lookupMock FindPassword penv,
                createUser = lookupMock CreateUser penv,
                hashPassword = lookupMock HashPassword penv,
                upsertAuth = lookupMock UpsertAuth penv
              }
          )
  before setup $ do
    context "accept valid impl" $ do
      it "accept valid impl findUser first" $ \(penv, service) -> do
        doService service usernm passwd `shouldReturn` Just (User usernm userid)
        verify penv
      it "accept valid impl hash first" $ \(penv, service) -> do
        doServiceHashFirst service usernm passwd `shouldReturn` Just (User usernm userid)
        verify penv
    context "reject invalid impl" $ do
      it "invalid argument" $ \(_, service) ->
        doServiceWrongArgument service usernm passwd `shouldThrow` anyErrorCall
      it "extra calls" $ \(_, service) ->
        doServiceWrongExtraCalls service usernm passwd `shouldThrow` anyErrorCall
      it "missing calls" $ \(penv, service) -> do
        doServiceWrongMissingCalls service usernm passwd `shouldReturn` Just (User usernm userid)
        verify penv `shouldThrow` anyErrorCall
      it "wrong order" $ \(_, service) -> do
        doServiceWrongOrder service usernm passwd `shouldThrow` anyErrorCall
      it "unspecified method call" $ \(_, service) -> do
        doServiceWrongUnspecifiedMethod service usernm passwd `shouldThrow` anyErrorCall