Types.hs

module Example.Types where

import TsWeb.Db (QueryResult(..), queryMaybe)
import TsWeb.Routing.Auth (Authorize(..))
import TsWeb.Session (UserData(..))
import TsWeb.Tables.Session (SessionT)

import qualified Data.Text as Text
import qualified Web.Spock as Spock

import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Database.Beam

data Db f = Db
  { _dbUser :: f (TableEntity UserT)
  , _dbSession :: f (TableEntity (SessionT SessionDataT))
  } deriving (Generic)

instance Database be Db

db :: DatabaseSettings be Db
db = defaultDbSettings

data UserT f = User
  { _userId :: C f Int
  , _userLogin :: C f Text
  } deriving (Generic)

type User = UserT Identity

type UserId = PrimaryKey UserT Identity

data SessionDataT f = SessionData
  { _sdUser :: PrimaryKey UserT (Nullable f)
  , _sdRemember :: C f Bool
  } deriving (Generic)

type SessionData = SessionDataT Identity

data Admin =
  Admin User
  deriving (Eq, Ord, Show)

adminP :: Proxy Admin
adminP = Proxy

instance Authorize SessionData Admin where
  checkAuth _ =
    _sdUser <$> Spock.readSession >>= \case
      UserId Nothing -> pure Nothing
      UserId (Just uid) ->
        queryMaybe (select $ q uid) >>= \case
          QSimply (Just user) ->
            if "-admin" `Text.isSuffixOf` _userLogin user
              then pure $ Just (Admin user)
              else pure Nothing
          _ -> pure Nothing
    where
      q uid = do
        u <- all_ $ _dbUser db
        guard_ $ _userId u ==. val_ uid
        pure u

userP :: Proxy User
userP = Proxy

instance Authorize SessionData User where
  checkAuth _ =
    _sdUser <$> Spock.readSession >>= \case
      UserId Nothing -> pure Nothing
      UserId (Just uid) ->
        queryMaybe (select $ q uid) >>= \case
          QSimply (Just user) -> pure $ Just user
          _ -> pure Nothing
    where
      q uid = do
        u <- all_ $ _dbUser db
        guard_ $ _userId u ==. val_ uid
        pure u

deriving instance Show (PrimaryKey UserT (Nullable Identity))

deriving instance Show (PrimaryKey UserT Identity)

deriving instance Show User

deriving instance Eq (PrimaryKey UserT (Nullable Identity))

deriving instance Eq (PrimaryKey UserT Identity)

deriving instance Eq User

deriving instance Ord (PrimaryKey UserT (Nullable Identity))

deriving instance Ord (PrimaryKey UserT Identity)

deriving instance Ord User

instance Beamable (PrimaryKey UserT)

instance Beamable UserT

instance Table UserT where
  data PrimaryKey UserT f = UserId (Columnar f Int)
                            deriving Generic
  primaryKey = UserId . _userId

deriving instance Show SessionData

deriving instance Eq SessionData

deriving instance Ord SessionData

instance Beamable SessionDataT

instance UserData SessionData where
  rememberMe = _sdRemember