Derive cascade-core package from cascade-api and cascade-prelude

cabal.project

@@ -1,4 +1,8 @@
-packages: cascade-prelude, cascade-api, cascade-cli
+packages:
+    cascade-prelude
+  , cascade-api
+  , cascade-cli
+  , cascade-core
 optimization: False
 documentation: True
 

cabal.project.freeze

@@ -1854,7 +1854,7 @@ constraints: AC-Angle ==1.0,
              relational-query-HDBC ==0.7.2.0,
              relational-record ==0.2.2.0,
              relational-schemas ==0.1.8.0,
-             relude ==0.7.0.0,
+             relude ==1.0.0.1,
              renderable ==0.2.0.1,
              replace-attoparsec ==1.4.4.0,
              replace-megaparsec ==1.4.4.0,

cascade-api/package.dhall

@@ -27,6 +27,7 @@ let cascade-api =
         [ "attoparsec"
         , "beam-core"
         , "beam-postgres"
+        , "cascade-core"
         , "chronos"
         , "either"
         , "email-validate"

cascade-api/src/Cascade/Api.hs

@@ -17,10 +17,10 @@ import qualified Cascade.Api.Effect.Database.Project
                                                     as Database.Project
 import qualified Cascade.Api.Effect.Database.Task   as Database.Task
 import qualified Cascade.Api.Effect.Database.User   as Database.User
-import qualified Cascade.Api.Effect.Scrypt          as Scrypt
 import qualified Cascade.Api.Effect.Time            as Time
 import           Cascade.Api.Network.Wai.Application
 import           Cascade.Api.Orphans                 ( )
+import qualified Cascade.Core.Effect.Scrypt         as Scrypt
 import qualified Database.PostgreSQL.Simple         as Postgres
 import qualified Network.Wai.Handler.Warp           as Warp
 import           Polysemy                            ( runFinal )

cascade-api/src/Cascade/Api/Data/Aeson/FieldErrorFormat.hs

@@ -0,0 +1,32 @@
+{-|
+Module      : Cascade.Api.Data.Aeson.FieldErrorFormat
+Description : !!! INSERT MODULE SHORT DESCRIPTION !!!
+Copyright   : (c) 2020-2021 Cascade
+License     : MPL 2.0
+Maintainer  : Mohammad Hasani <[email protected]> (the-dr-lazy.github.io)
+Stability   : Stable
+Portability : POSIX
+
+!!! INSERT MODULE LONG DESCRIPTION !!!
+-}
+
+{-# LANGUAGE UndecidableInstances #-}
+
+module Cascade.Api.Data.Aeson.FieldErrorFormat (FieldErrorFormat(..)) where
+
+import qualified Data.Aeson                         as Aeson
+import           Data.Aeson                          ( FromJSON
+                                                     , ToJSON
+                                                     )
+import           GHC.Generics                        ( Rep )
+
+newtype FieldErrorFormat (error :: Type) = FieldErrorFormat error
+
+options :: Aeson.Options
+options = Aeson.defaultOptions { Aeson.tagSingleConstructors = True, Aeson.omitNothingFields = True }
+
+instance (Generic error, Aeson.GToJSON Aeson.Zero (Rep error)) => ToJSON (FieldErrorFormat error) where
+  toJSON (FieldErrorFormat e) = Aeson.genericToJSON options e
+
+instance (Generic error, Aeson.GFromJSON Aeson.Zero (Rep error)) => FromJSON (FieldErrorFormat error) where
+  parseJSON = fmap FieldErrorFormat . Aeson.genericParseJSON options

cascade-api/src/Cascade/Api/Data/Aeson/RecordErrorFormat.hs

@@ -0,0 +1,32 @@
+{-|
+Module      : Cascade.Api.Data.Aeson.RecordErrorFormat
+Description : !!! INSERT MODULE SHORT DESCRIPTION !!!
+Copyright   : (c) 2020-2021 Cascade
+License     : MPL 2.0
+Maintainer  : Mohammad Hasani <[email protected]> (the-dr-lazy.github.io)
+Stability   : Stable
+Portability : POSIX
+
+!!! INSERT MODULE LONG DESCRIPTION !!!
+-}
+
+{-# LANGUAGE UndecidableInstances #-}
+
+module Cascade.Api.Data.Aeson.RecordErrorFormat (RecordErrorFormat(..)) where
+
+import qualified Data.Aeson                         as Aeson
+import           Data.Aeson                          ( FromJSON
+                                                     , ToJSON
+                                                     )
+import           GHC.Generics                        ( Rep )
+
+newtype RecordErrorFormat (error :: Type) = RecordErrorFormat error
+
+options :: Aeson.Options
+options = Aeson.defaultOptions { Aeson.omitNothingFields = True }
+
+instance (Generic error, Aeson.GToJSON Aeson.Zero (Rep error)) => ToJSON (RecordErrorFormat error) where
+  toJSON (RecordErrorFormat e) = Aeson.genericToJSON options e
+
+instance (Generic error, Aeson.GFromJSON Aeson.Zero (Rep error)) => FromJSON (RecordErrorFormat error) where
+  parseJSON = fmap RecordErrorFormat . Aeson.genericParseJSON options

cascade-api/src/Cascade/Api/Data/Authentication.hs

@@ -10,32 +10,33 @@ Portability : POSIX
 !!! INSERT MODULE LONG DESCRIPTION !!!
 -}
 
-module Cascade.Api.Data.Authentication (RawCredential(..), ParsedCredential, parseRawCredential) where
+{-# LANGUAGE UndecidableInstances #-}
+module Cascade.Api.Data.Authentication (Credential(..), parseRawCredential) where
 
+import qualified Cascade.Api.Data.Aeson.RecordErrorFormat
+                                                    as Aeson
 import qualified Cascade.Api.Data.ByteString.Password
                                                     as Password
 import qualified Cascade.Api.Data.Text.Username     as Username
 import qualified Cascade.Api.Data.User              as User
+import           Cascade.Data.Validation             ( Validate
+                                                     , Validation
+                                                     )
+import qualified Cascade.Data.Validation            as Validation
 import           Data.Aeson                          ( FromJSON
                                                      , ToJSON
                                                      )
-import           Validation
 
-data RawCredential = RawCredential
-  { username :: Text
-  , password :: Text
+-- brittany-disable-next-binding
+data Credential (p :: Validation.Phase) = Credential
+  { username :: Validate p Text User.Username
+  , password :: Validate p Text User.Password
   }
-  deriving stock (Generic, Show, Eq)
-  deriving anyclass (FromJSON, ToJSON)
+  deriving stock Generic
 
-data ParsedCredential = ParsedCredential
-  { username :: User.Username
-  , password :: User.Password
-  }
-  deriving stock (Generic, Show, Eq)
+deriving stock instance Show (Credential 'Validation.Raw)
+deriving via Aeson.RecordErrorFormat (Credential 'Validation.Raw) instance ToJSON (Credential 'Validation.Raw)
+deriving via Aeson.RecordErrorFormat (Credential 'Validation.Raw) instance FromJSON (Credential 'Validation.Raw)
 
-parseRawCredential :: RawCredential -> Validation () ParsedCredential
-parseRawCredential RawCredential {..} =
-  let validateUsername = Username.mk username |> first mempty
-      validatePassword = Password.mk password |> first mempty
-  in  ParsedCredential <$> validateUsername <*> validatePassword
+parseRawCredential :: Credential 'Validation.Raw -> Validation () (Credential 'Validation.Parsed)
+parseRawCredential = first mempty . Validation.parseRecord Credential { username = Username.mk, password = Password.mk }

cascade-api/src/Cascade/Api/Data/ByteString/Password.hs

@@ -10,14 +10,17 @@ Portability : POSIX
 !!! INSERT MODULE LONG DESCRIPTION !!!
 -}
 
-module Cascade.Api.Data.ByteString.Password (Password, pattern Password, ValidationError(..), ValidationErrors, mk, un) where
+module Cascade.Api.Data.ByteString.Password (Password, pattern Password, Error(..), Errors, mk, un) where
 
+import qualified Cascade.Api.Data.Aeson.FieldErrorFormat
+                                                    as Aeson
+import           Cascade.Data.Validation             ( Validation )
+import qualified Cascade.Data.Validation            as Validation
 import           Control.Selective                   ( ifS )
 import           Data.Aeson                          ( FromJSON
                                                      , ToJSON
                                                      )
 import qualified Data.Text                          as Text
-import           Validation
 
 newtype Password = Mk
   { un :: ByteString }
@@ -27,16 +30,19 @@ pattern Password :: ByteString -> Password
 pattern Password a <- Mk a
 {-# COMPLETE Password #-}
 
-data ValidationError
+data Error
   = IsEmpty
   | IsShort
   deriving stock (Generic, Show)
-  deriving anyclass (FromJSON, ToJSON)
+  deriving ToJSON via Aeson.FieldErrorFormat Error
+  deriving FromJSON via Aeson.FieldErrorFormat Error
 
-type ValidationErrors = NonEmpty ValidationError
+type Errors = NonEmpty Error
 
-mk :: Text -> Validation ValidationErrors Password
+type instance Validation.Errors Text Password = Errors
+
+mk :: Text -> Validation Errors Password
 mk input = Mk (encodeUtf8 input) <$ validate input
 
-validate :: Text -> Validation ValidationErrors ()
-validate input = ifS (pure $ Text.null input) (failure IsEmpty) (failureIf (Text.length input < 8) IsShort)
+validate :: Text -> Validation Errors ()
+validate input = ifS (pure $ Text.null input) (Validation.failure IsEmpty) (Validation.failureIf (Text.length input < 8) IsShort)

cascade-api/src/Cascade/Api/Data/OffsetDatetime/Deadline.hs

@@ -10,9 +10,39 @@ Portability : POSIX
 !!! INSERT MODULE LONG DESCRIPTION !!!
 -}
 
-module Cascade.Api.Data.OffsetDatetime.Deadline (Deadline, un, mk) where
+module Cascade.Api.Data.OffsetDatetime.Deadline (Deadline, un, mk, parse) where
 
-import           Cascade.Data.Chronos.Future
-import           Chronos                             ( OffsetDatetime )
+import qualified Cascade.Api.Data.Aeson.FieldErrorFormat
+                                                    as Aeson
+import           Cascade.Api.Data.OffsetDatetime     ( FormattedOffsetDatetime )
+import           Cascade.Data.Chronos.Future         ( Future )
+import qualified Cascade.Data.Chronos.Future        as Future
+import           Cascade.Data.Validation             ( Validation )
+import qualified Cascade.Data.Validation            as Validation
+import           Chronos                             ( OffsetDatetime
+                                                     , Time
+                                                     )
+import           Data.Aeson                          ( FromJSON
+                                                     , ToJSON
+                                                     )
 
-type Deadline = Future OffsetDatetime
+newtype Deadline = Deadline (Future OffsetDatetime)
+  deriving stock Show
+
+un :: Deadline -> OffsetDatetime
+un (Deadline future) = Future.un future
+
+mk :: Time -> OffsetDatetime -> Maybe Deadline
+mk now input = Deadline <$> Future.mk input now
+
+data Error = IsPast
+  deriving stock (Generic, Show)
+  deriving (ToJSON, FromJSON) via Aeson.FieldErrorFormat Error
+
+type Errors = NonEmpty Error
+
+type instance Validation.Errors OffsetDatetime Deadline = Errors
+type instance Validation.Errors FormattedOffsetDatetime Deadline = Errors
+
+parse :: Time -> OffsetDatetime -> Validation Errors Deadline
+parse now = Validation.maybeToSuccess (IsPast :| []) . mk now