Factory.hs

-- | Monad from Yesod with HasPostgresql instances and such stuff
type Handler a = HandlerT App IO a

-- | Generates value if it is not presented in given DMap or just gets
-- it from DMap if presented
dmLookupOr :: (Applicative m, DM.GCompare k)
           => DMap k             -- ^ depmap to take value from
           -> k a                -- ^ key to find value of
           -> m a                -- ^ action to produce value if key not found
           -> m a
dmLookupOr dmap key prod =
    let v = DM.lookup key dmap
    in maybe
       prod
       pure
       v

-- | Returns User entity and password
newUser :: Handler (Ent User, Ent Email, Password)
newUser = do
    ident <- liftIO nextRandom
    pass <- liftIO $ Password . T.pack
    .................
    -- Тут мы генерируем пользователя и его мыло с изначальным паролем странным сложным способом
    -- очевидимо чтобы можно было залогиниться через симулятор браузера или типа того

newClientApp :: DMap ClientAppTag -- ^ map with predefined field values
             -> Handler (Ent ClientApp)
newClientApp dmap = do
    capp <- ClientApp
            <$> dd ClientAppUserId -- Если ключа нет, то генерируем нового юзера
            ((\((uid,_), _, _) -> Just uid) <$> newUser)
            <*> dd ClientAppName -- Если ключа нет, то генерируем рандомную строку в качестве имени
            (liftIO $ T.pack <$> generateTokenLikeString)
            <*> dd ClientAppWebsite (pure Nothing) -- Если ключа нет, то оставляем Nothing 
            <*> dd ClientAppComment (pure Nothing)
            <*> dd ClientAppActive  (pure True)
            <*> dd ClientAppPublished (pure True)
    appid <- pgInsertEntity capp -- Можно было бы и не инсертить прямо тут, но не суть
    return (appid, capp)
  where
    dd :: ClientAppTag a -- ^ Ключ, по которому DMap лежит дефолт 
        -> Handler a     -- ^ Если не лежит, то генерируем действие этим действием
        -> Handler a
    dd key act = dmLookupOr dmap key act


newClient :: DMap ClientTag      -- ^ map with predefined values of client
          -> Handler (Ent Client)
newClient dmap = do
    client <- Client
              <$> dd ClientApplicationId -- Если ключа нет, то генерируем ClientApp функцией выше, передаем в нее пустую DMap (все дефолтное)
              (fst <$> newClientApp DM.empty)
              <*> dd ClientRedirectURI
              (liftIO $ Just
               <$> randomURI "/redirect" Nothing Nothing)
              <*> dd ClientClientId
              (liftIO $ (ClientIdText . T.pack)
               <$> generateTokenLikeString)
              <*> dd ClientSecret
              (liftIO $ T.pack
               <$> generateTokenLikeString)
              <*> dd ClientClientType (pure CTStandartFlow)
              <*> dd ClientActive     (pure True)
              <*> dd ClientComment    (pure Nothing)
              <*> dd ClientAutoRedirect (pure False)
    cid <- pgInsertEntity client -- Тут тоже можно было бы не инсертить, по нормальному.
    return (cid, client)
  where
    dd :: ClientTag a -> Handler a -> Handler a
    dd key act = dmLookupOr dmap key act

Models.hs

data User = User
    { userIdentifier        :: !UserIdentifier
    , userName              :: !(Maybe Text)
    , userPasswordEncrypted :: !Text
    , userPhone             :: !(Maybe Text)
    , userLevel             :: !Integer
    } deriving (Show, Eq, Ord, Typeable)

type UserId = EntityId User

instance Entity User where
    newtype EntityId User = UserId
        { unUserId :: Id
        } deriving (Show, Read, Ord, Eq,
                    FromField, ToField, PathPiece)
    tableName _ = "users"
    fieldNames _ = [ "user_identifier", "name"
                   , "password_encrypted", "phone"
                   , "level"
                   ]


$(deriveFromRow ''User)
$(deriveToRow ''User)


data ClientApp = ClientApp
    { appUserId       :: !(Maybe (EntityId User)) -- ^ Application owner
    , appName         :: !T.Text
    , appWebsite      :: !(Maybe URI)
    , appComment      :: !(Maybe Text)
    , appActive       :: !Bool
    , appPublished    :: !Bool
    } deriving (Show, Eq, Typeable)

instance Entity ClientApp where
    newtype EntityId ClientApp = ClientAppId Id
        deriving (Show, Read, Ord, Eq, ToMarkup,
                  PathPiece, FromField, ToField)

    tableName _ = "applications"
    fieldNames _ = [ "user_id", "name", "website"
                   , "comment", "active", "published" ]

$(deriveFromRow ''ClientApp)
$(deriveToRow ''ClientApp)

type ClientAppId = EntityId ClientApp



data Client = Client
    { clApplicationId :: !(EntityId ClientApp)
    , clRedirectURI   :: !(Maybe URI)
    , clClientId      :: !ClientIdText
    , clClientSecret  :: !Text
    , clClientType    :: !ClientType
    , clActive        :: !Bool
    , clComment       :: !(Maybe Text)
    , clAutoRedirect  :: !Bool
    } deriving (Show, Eq, Ord, Typeable)

instance Entity Client where
    newtype EntityId Client = ClientId
        { unClientId :: Id
        } deriving (Show, Read, Ord, Eq,
                    FromField, ToField, PathPiece)


    tableName _ = "clients"
    fieldNames _ = [ "application_id", "redirect_uri"
                   , "client_id", "client_secret", "client_type"
                   , "active", "comment", "auto_redirect"
                   ]

$(deriveToRow ''Client)
$(deriveFromRow ''Client)

type ClientAppId = EntityId ClientApp

Tags.hs

-- There is no UserTag for some reason ...

-- Теги для DMap 
-- 
-- > data DMap k 
-- > 
-- > data DSum tag :: (* -> *) -> * where
-- >      (:=>) :: !(tag a) -> a -> DSum tag
-- >
-- > fromList :: GCompare k => [DSum k] -> DMap k 
-- > 
-- > lookup :: forall k v. GCompare k => k v -> DMap k -> Maybe v 
-- 
-- Это типы как раз вместо `k`

data ClientAppTag a where
    ClientAppUserId    :: ClientAppTag (Maybe (EntityId User))
    ClientAppName      :: ClientAppTag Text
    ClientAppWebsite   :: ClientAppTag (Maybe URI)
    ClientAppComment   :: ClientAppTag (Maybe Text)
    ClientAppActive    :: ClientAppTag Bool
    ClientAppPublished :: ClientAppTag Bool
$(deriveGEq ''ClientAppTag)
$(deriveGCompare ''ClientAppTag)

data ClientTag a where
    ClientApplicationId :: ClientTag (EntityId ClientApp)
    ClientRedirectURI   :: ClientTag (Maybe URI)
    ClientClientId      :: ClientTag ClientIdText
    ClientSecret        :: ClientTag Text
    ClientClientType    :: ClientTag ClientType
    ClientActive        :: ClientTag Bool
    ClientComment       :: ClientTag (Maybe Text)
    ClientAutoRedirect  :: ClientTag Bool
$(deriveGEq ''ClientTag)
$(deriveGCompare ''ClientTag)