diff --git a/.gitignore b/.gitignore index a4ee41a..f3f3425 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,4 @@ cabal.sandbox.config *.eventlog .stack-work/ cabal.project.local +Conf.hs diff --git a/ServantOpaleye/stack.yaml b/ServantOpaleye/stack.yaml index b3caacb..9959759 100644 --- a/ServantOpaleye/stack.yaml +++ b/ServantOpaleye/stack.yaml @@ -63,4 +63,4 @@ extra-package-dbs: [] # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file +# compiler-check: newer-minor diff --git a/SpockOpaleye/SpockOpaleye.cabal b/SpockOpaleye/SpockOpaleye.cabal index 34715c8..c701a74 100644 --- a/SpockOpaleye/SpockOpaleye.cabal +++ b/SpockOpaleye/SpockOpaleye.cabal @@ -15,26 +15,42 @@ cabal-version: >=1.10 library hs-source-dirs: src - exposed-modules: Lib, - TenantApi, + exposed-modules: TenantApi, UserApi, RoleApi, - OpaleyeDef, - CryptoDef, JsonInstances, Validations, - DataTypes + Conf, + UserServices, + Email build-depends: base >= 4.7 && < 5 + ,appcore + ,smtp-mail + ,lifted-base + ,airbrake + ,here + ,filepath + ,mime-mail >= 0.4.12 ,product-profunctors + ,profunctors ,bytestring ,opaleye + ,time + ,old-time + ,network ,postgresql-simple ,bcrypt ,text ,lens ,mtl + ,transformers + ,time + ,vector ,Spock >=0.11 ,aeson + ,unordered-containers + ,template-haskell + ,lifted-base default-language: Haskell2010 executable SpockOpaleye-exe @@ -43,13 +59,27 @@ executable SpockOpaleye-exe ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns build-depends: base , postgresql-simple + , airbrake + , bytestring + , appcore + , here + , mime-mail + , filepath + , smtp-mail + , network + , old-time , SpockOpaleye , Spock >=0.11 , mtl + , transformers , lens , text + , time , bcrypt + , vector , aeson + , unordered-containers + , lifted-base default-language: Haskell2010 test-suite SpockOpaleye-test diff --git a/SpockOpaleye/app/Main.hs b/SpockOpaleye/app/Main.hs index 36fce98..8f20d8c 100644 --- a/SpockOpaleye/app/Main.hs +++ b/SpockOpaleye/app/Main.hs @@ -1,23 +1,38 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where - +import AppCore import Database.PostgreSQL.Simple -import DataTypes import JsonInstances () import TenantApi import Validations +import Email import Web.Spock import Web.Spock.Config +import Control.Monad.Reader +import Control.Monad.Writer +import qualified Control.Monad.Reader as R import qualified Data.Text as T +import Data.Time +import Prelude hiding (id) +import UserServices +import Control.Monad.Trans.Except +import Control.Exception.Lifted +import Airbrake +import Airbrake.WebRequest +import Data.ByteString (ByteString) -data MySession = - EmptySession +data MySession = EmptySession data MyAppState = DummyAppState +data AppResult a = AppOk a | AppErr T.Text + connectDb :: IO Connection connectDb = connect defaultConnectInfo { connectDatabase = "haskell-webapps" } @@ -30,19 +45,41 @@ main = do DummyAppState runSpock 8080 (spock spockCfg app) +runAppM :: AppM a -> Connection -> IO (AppResult a) +runAppM x conn = do + user <- getTestUser + r <- runExceptT $ handle throwE $ runReaderT (runWriterT x) (conn, Just $ getTestTenant, Just $ user) + case r of + Right (item, lg) -> do + return $ AppOk item + Left ex -> do + let message = T.pack $ show ex + return $ AppErr message + +runWithLogging :: ActionT (WebStateM Connection MySession MyAppState) (AppResult a) + -> (a -> ActionT (WebStateM Connection MySession MyAppState) ()) + -> ActionT (WebStateM Connection MySession MyAppState) () +runWithLogging act sact = do + r <- act + case r of + AppOk rOk -> sact rOk + AppErr msg -> do + r <- request + liftIO $ notifyReq conf (waiRequestToRequest r) (Error "Uncaught exception" msg) (("Filename", 5):|[]) + json $ T.pack "There was an error. Please try again later" + where + conf = airbrakeConf "61a1adfc070a9be9f21e43f586bbf5f7" "Env" + app :: SpockM Connection MySession MyAppState () app = do - post ("tenants/new") $ - do maybe_tenant_incoming <- jsonBody - maybe_newtenant <- - case maybe_tenant_incoming of - Just incoming_tenant -> do - result <- - runQuery (\conn -> validateIncomingTenant conn incoming_tenant) - case result of - Valid -> runQuery (\conn -> create_tenant conn incoming_tenant) - _ -> return Nothing - Nothing -> return Nothing - case maybe_newtenant of - Just tenant -> json tenant - _ -> json $ T.pack "Tenant not created" + get ("tenants") $ do + runWithLogging (runQuery $ runAppM readTenants) (\tenants ->json tenants) + post ("tenants/new") $ runWithLogging (do + maybeTenantIncoming <- jsonBody + runQuery $ runAppM $ do + case maybeTenantIncoming of + Just incomingTenant -> doCreateTenant incomingTenant + Nothing -> return $ Left $ T.pack "Unrecognized input" + ) (\et -> case et of + Right new_tenant -> json new_tenant + Left message -> json message) diff --git a/SpockOpaleye/appcore/LICENSE b/SpockOpaleye/appcore/LICENSE new file mode 100644 index 0000000..fc03544 --- /dev/null +++ b/SpockOpaleye/appcore/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/SpockOpaleye/appcore/Setup.hs b/SpockOpaleye/appcore/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/SpockOpaleye/appcore/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SpockOpaleye/appcore/app/Main.hs b/SpockOpaleye/appcore/app/Main.hs new file mode 100644 index 0000000..de1c1ab --- /dev/null +++ b/SpockOpaleye/appcore/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc diff --git a/SpockOpaleye/appcore/appcore.cabal b/SpockOpaleye/appcore/appcore.cabal new file mode 100644 index 0000000..dd2a135 --- /dev/null +++ b/SpockOpaleye/appcore/appcore.cabal @@ -0,0 +1,67 @@ +name: appcore +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/githubuser/appcore#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2016 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + ,src/User + ,src/Role + ,src/Tenant + exposed-modules: AppCore + other-modules: Auditable + ,AuditableTH + ,CryptoDef + ,OpaleyeDef + ,UserDefs + ,TenantDefs + ,RoleDefs + ,Lenses + ,UserId + ,TenantId + ,Utils + ,AppM + ,ApiBase + ,UserApi + ,TenantApi + build-depends: base >= 4.7 && < 5 + , aeson + , transformers + , text + , lens + , time + , old-time + , product-profunctors + , profunctors + , vector + , bytestring + , opaleye + , postgresql-simple + , template-haskell + , unordered-containers + , bcrypt + , mtl + default-language: Haskell2010 + +test-suite appcore-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , appcore + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/githubuser/appcore diff --git a/SpockOpaleye/appcore/src/ApiBase.hs b/SpockOpaleye/appcore/src/ApiBase.hs new file mode 100644 index 0000000..01fcb3b --- /dev/null +++ b/SpockOpaleye/appcore/src/ApiBase.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module ApiBase where + +import AppM +import UserDefs +import TenantDefs +import OpaleyeDef +import Lenses +import Auditable +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Reader +import qualified Control.Monad.Reader as R +import Control.Monad.Writer +import qualified Data.Profunctor.Product.Default as D +import Data.Time (UTCTime, getCurrentTime) +import Opaleye +import qualified Data.Text as T +import GHC.Int +import Prelude hiding (id) +import Data.Aeson (Value(..)) +import Data.ByteString (ByteString) +import Database.PostgreSQL.Simple + +removeRawDbRows :: Table columnsW columnsR -> (columnsR -> Column PGBool) -> AppM GHC.Int.Int64 +removeRawDbRows table matchFunc = do + conn <- getConnection + liftIO $ runDelete conn table matchFunc + +createDbRows :: (Show columnsW, D.Default QueryRunner columnsR haskells) + => Table columnsW columnsR -> [columnsW] -> AppM [haskells] +createDbRows table pgrows = do + --auditLog $ "Create : " ++ (show pgrows) + conn <- getConnection + liftIO $ runInsertManyReturning conn table pgrows (\x -> x) + +updateDbRow :: (Show columnsW, HasId columnsR (Column PGInt4)) => Table columnsW columnsR -> Column PGInt4 -> columnsW -> AppM columnsW +updateDbRow table row_id item = do + --auditLog $ "Update :" ++ (show item) + conn <- getConnection + _ <- liftIO $ runUpdate conn table (\_ -> item) (matchFunc row_id) + return item + where + matchFunc :: (HasId cmR (Column PGInt4)) => (Column PGInt4 -> cmR -> Column PGBool) + matchFunc itId item' = (item' ^. id) .== itId + +createRow ::( + Show incoming, + Show columnsW, + HasCreatedat columnsW (Maybe (Column PGTimestamptz)), + HasUpdatedat columnsW (Column PGTimestamptz), + D.Default Constant incoming columnsW, D.Default QueryRunner returned row) + => Table columnsW returned -> incoming -> AppM row +createRow table item = do + --auditLog $ "Create : " ++ (show item) + currentTime <- liftIO $ fmap pgUTCTime getCurrentTime + let itemPg = (constant item) & createdat .~ (Just currentTime) & updatedat .~ (currentTime) + fmap (head) $ createDbRows table [itemPg] + +updateRow :: ( + Show columnsW + , Show haskells + , HasUpdatedat haskells UTCTime + , D.Default Constant haskells columnsW + , D.Default Constant itemId (Column PGInt4) + , HasId haskells itemId + , HasId columnsR (Column PGInt4) + ) + => Table columnsW columnsR -> haskells -> AppM haskells +updateRow table item = do + --auditLog $ "Update : " ++ (show item) + let itId = item ^. id + currentTime <- liftIO getCurrentTime + let updatedItem = (putUpdatedTimestamp currentTime) item + _ <- updateDbRow table (constant itId) (constant updatedItem) + return updatedItem + where + putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item + putUpdatedTimestamp timestamp = updatedat .~ timestamp + +updateAuditableRow :: ( + Show columnsW + , HasUpdatedat (Auditable haskells) UTCTime + , D.Default Constant haskells columnsW + , D.Default Constant itemId (Column PGInt4) + , HasId (Auditable haskells) itemId + , HasId columnsR (Column PGInt4) + ) + => Table columnsW columnsR -> Auditable haskells -> AppM (Auditable haskells) +updateAuditableRow table audti = do + --auditLog $ "Update : " ++ (show item) + let itId = audti ^. id + currentTime <- liftIO getCurrentTime + let updatedItem = (putUpdatedTimestamp currentTime) audti + let Auditable { _data = item, _log = _log} = updatedItem + _ <- updateDbRow table (constant itId) (constant item) + insertIntoLog table itId "" _log + return audti + where + putUpdatedTimestamp :: (HasUpdatedat item (UTCTime)) => UTCTime -> item -> item + putUpdatedTimestamp timestamp = updatedat .~ timestamp + +insertIntoLog :: ( + D.Default Constant item_id (Column PGInt4) + ) => Table a b -> item_id -> T.Text -> Value -> AppM () +insertIntoLog table auditable_id summary changes = do + case table of + Table table_name _ -> do + Just tenant <- getCurrentTenant + Just user <- getCurrentUser + conn <- getConnection + let tenant_id = tenant ^. id + let user_id = user ^. id + _ <- liftIO $ runInsertMany conn auditTable [( + (), + constant tenant_id, + Just $ constant user_id, + Just $ pgBool False, + constant auditable_id, + pgStrictText $ T.pack table_name, + pgStrictText $ summary, + constant changes, + Nothing)] + return () + _ -> error "Unsupported Table constructor" + +removeAuditableRow :: ( + Show haskells + , D.Default Constant itemId (Column PGInt4) + , HasId haskells itemId + , HasId columnsR (Column PGInt4) + ) => Table columnsW columnsR -> Auditable haskells -> AppM GHC.Int.Int64 +removeAuditableRow table item_r = do + --auditLog $ "Remove : " ++ (show item) + conn <- getConnection + let Auditable { _data = item, _log = _log} = item_r + liftIO $ do + runDelete conn table $ matchFunc $ item ^. id + where + matchFunc :: ( + HasId columnsR (Column PGInt4), + D.Default Constant itemId (Column PGInt4) + ) => (itemId -> columnsR -> Column PGBool) + matchFunc itId item' = (item' ^. id) .== (constant itId) + +removeRow :: ( + Show haskells + , D.Default Constant itemId (Column PGInt4) + , HasId haskells itemId + , HasId columnsR (Column PGInt4) + ) => Table columnsW columnsR -> haskells -> AppM GHC.Int.Int64 +removeRow table item = do + --auditLog $ "Remove : " ++ (show item) + conn <- getConnection + liftIO $ do + runDelete conn table $ matchFunc $ item ^. id + where + matchFunc :: ( + HasId columnsR (Column PGInt4), + D.Default Constant itemId (Column PGInt4) + ) => (itemId -> columnsR -> Column PGBool) + matchFunc itId item' = (item' ^. id) .== (constant itId) + +readRow :: (D.Default QueryRunner columnsR haskells) => + Opaleye.Query columnsR -> AppM [haskells] +readRow query' = do + conn <- getConnection + liftIO $ runQuery conn query' diff --git a/SpockOpaleye/appcore/src/AppCore.hs b/SpockOpaleye/appcore/src/AppCore.hs new file mode 100644 index 0000000..e6a6e2e --- /dev/null +++ b/SpockOpaleye/appcore/src/AppCore.hs @@ -0,0 +1,32 @@ +module AppCore ( + module UserDefs + ,module UserId + ,module TenantDefs + ,module TenantId + ,module RoleDefs + ,module Lenses + ,module CryptoDef + ,Auditable + ,module ApiBase + ,module OpaleyeDef + ,module UserApi + ,module TenantApi + ,AppM + ,auditable + ,wrapAuditable +) where + +import UserDefs hiding (InternalUser) +import RoleDefs hiding (InternalRole) +import TenantDefs hiding (InternalTenant) +import TenantId +import UserId +import Lenses +import CryptoDef +import Auditable +import OpaleyeDef +import Utils +import ApiBase +import UserApi +import TenantApi +import AppM diff --git a/SpockOpaleye/appcore/src/AppM.hs b/SpockOpaleye/appcore/src/AppM.hs new file mode 100644 index 0000000..a1ab7d2 --- /dev/null +++ b/SpockOpaleye/appcore/src/AppM.hs @@ -0,0 +1,28 @@ +module AppM where + +import UserDefs +import TenantDefs +import qualified Control.Monad.Reader as R +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Data.ByteString +import Control.Exception +import Database.PostgreSQL.Simple +import Control.Monad.Trans.Except + +type AppM a = WriterT ByteString (ReaderT (Connection, Maybe Tenant, Maybe User) (ExceptT SomeException IO)) a + +getCurrentUser :: AppM (Maybe User) +getCurrentUser = do + (_, _, user) <- R.ask + return user + +getCurrentTenant :: AppM (Maybe Tenant) +getCurrentTenant = do + (_, tenant, _) <- R.ask + return tenant + +getConnection :: AppM Connection +getConnection = do + (conn, tenant, _) <- R.ask + return conn diff --git a/SpockOpaleye/appcore/src/Auditable.hs b/SpockOpaleye/appcore/src/Auditable.hs new file mode 100644 index 0000000..e7efa01 --- /dev/null +++ b/SpockOpaleye/appcore/src/Auditable.hs @@ -0,0 +1,5 @@ +module Auditable where + +import Data.Aeson.Types + +data Auditable a = Auditable { _data:: a, _log:: Value } deriving (Show) diff --git a/SpockOpaleye/appcore/src/AuditableTH.hs b/SpockOpaleye/appcore/src/AuditableTH.hs new file mode 100644 index 0000000..a497f7d --- /dev/null +++ b/SpockOpaleye/appcore/src/AuditableTH.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module AuditableTH where + +import Control.Lens +import Language.Haskell.TH +import Data.Char +import Data.List (elemIndex) +import qualified Data.HashMap.Strict as HM +import Data.Text (pack) +import Auditable + +import Data.Aeson (Value(..), ToJSON(..)) + +getTypeSegs :: Type -> [Type] +getTypeSegs a@(ConT _) = [a] +getTypeSegs (AppT a b) = (b : getTypeSegs a) +getTypeSegs r = error $ show r + +typeToName :: Type -> Name +typeToName (ConT n) = n +typeToName _ = error "Unsupported type constructor" + +getType :: Name -> TypeQ +getType tn = do + info <- reify tn + case info of + TyConI (TySynD _ _ tpe) -> return tpe + _ -> return (ConT tn) + +-- This will generate lenses that can operate on +-- models wrapped in Auditable wrapper. The setters +-- thus generated will also take care of capturing the +-- audit log diffs and store them in the _log fields of +-- the Auditable wrapper + +-- Inspect a name: $(stringE . show =<< reify ''DataTypes.Role) + +makeAuditableLenses :: Name -> Q [Dec] +makeAuditableLenses tq= do + a <- getType tq + let type_segs = reverse $ getTypeSegs a + let n = typeToName $ head type_segs + let record_name = nameBase n + field_names <- getRecordFields n + type_params <- getTypeParams n + concat <$> (sequence $ (mkInstanceDef record_name a type_params type_segs) <$> ((\(x, y) -> (nameBase x, y)) <$> field_names)) + where + mkInstanceDef :: String -> Type -> [Name] -> [Type] -> (String, Type) -> Q [Dec] + mkInstanceDef rec_name t_type type_params type_segs (field, typ) = do + let resolved_type = resolve_type typ type_params type_segs + let fname_rt = (drop (1+(length rec_name)) $ (toLower <$> field)) + tx <- lookupValueName fname_rt + let fname_ap = case tx of + Just x -> x + _ -> error (show fname_rt) + expr <- mkInstanceFunction field + do + let tc = "Has" ++ (uc_first fname_rt) + maybe_c <- lookupTypeName tc + case maybe_c of + Just c_name -> do + aud_t <- [t| Auditable $(return t_type) |] + return $ [InstanceD Nothing [] (AppT (AppT (ConT c_name) aud_t) resolved_type) [FunD (fname_ap) $ [Clause [] (NormalB expr) []] ]] + _ -> error $ "Typeclass " ++ tc ++ " not found" + where + uc_first (x:xs) = (toUpper x):xs + uc_first [] = [] + resolve_type :: Type -> [Name] -> [Type] -> Type + resolve_type (VarT n) tp ts = case (elemIndex n tp) of + Just idx -> (ts !! (idx + 1)) + _ -> error "Unknown type variable" + resolve_type t _ _ = t + +getTypeParams :: Name -> Q [Name] +getTypeParams t_name = do + info <- reify t_name + case info of + TyConI (DataD _ _ params _ [RecC _ _] _) -> return $ toName <$> params + _ -> error $ "Not a record!" ++ (show info) + where + toName (KindedTV n _) = n + toName _ = error "Unexpected type variable type" + +getRecordFields :: Name -> Q [(Name, Type)] +getRecordFields t_name = do + info <- reify t_name + case info of + TyConI (DataD _ _ _ _ [RecC _ t] _) -> return $ ext <$> t + _ -> error $ "Not a record!" ++ (show info) + where + ext (a, _, t) = (a, t) + +makeLog :: (ToJSON a) => Value -> String -> a -> a -> Value +makeLog current_log field_name old new = case current_log of + Object v -> Object $ HM.insert field_name_txt (getLog old new) v + _ -> error "Unexpected value in the log field" + where + field_name_txt = pack field_name + getLog :: (ToJSON v) => v -> v -> Value + getLog old' new' = Object $ HM.insert "old" (toJSON old') $ HM.insert "new" (toJSON new') $ HM.empty + +mkInstanceFunction :: String -> Q Exp +mkInstanceFunction nam = do + Just _field_name <- lookupValueName nam + -- TODO remove dependency on "DataTypes" module name or don't hard code it in. + fn <- lookupValueName $ "Lenses." ++ (transformName nam) + case fn of + Just field_name -> do + [| lens ($(return $ VarE _field_name)._data) (\r v -> r { + _data = _data r & ($(return $ VarE field_name) .~ v), + _log = makeLog (_log r) nam (_data r ^. $(return $ VarE field_name)) v + }) |] + _ -> error $ "field accessor not found for " ++ nam + where + transformName :: String -> String + transformName na = toLower <$> (dropWhile isLower (drop 1 na)) diff --git a/SpockOpaleye/src/CryptoDef.hs b/SpockOpaleye/appcore/src/CryptoDef.hs similarity index 91% rename from SpockOpaleye/src/CryptoDef.hs rename to SpockOpaleye/appcore/src/CryptoDef.hs index 1464138..15b783b 100644 --- a/SpockOpaleye/src/CryptoDef.hs +++ b/SpockOpaleye/appcore/src/CryptoDef.hs @@ -14,6 +14,7 @@ import Data.Text import Data.Text.Encoding import Database.PostgreSQL.Simple.FromField import Opaleye +import Data.Aeson (ToJSON(..), Value(..)) newtype BcryptPassword = BcryptPassword ByteString @@ -38,3 +39,6 @@ instance FromField BcryptPassword where instance QueryRunnerColumnDefault PGBytea BcryptPassword where queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance ToJSON BcryptPassword where + toJSON _ = String "" diff --git a/SpockOpaleye/appcore/src/Lenses.hs b/SpockOpaleye/appcore/src/Lenses.hs new file mode 100644 index 0000000..c236ee3 --- /dev/null +++ b/SpockOpaleye/appcore/src/Lenses.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Lenses where + +import Control.Lens +import Language.Haskell.TH +import UserDefs +import TenantDefs +import RoleDefs +import AuditableTH +import Prelude hiding (id) + +$(makeLensesWith abbreviatedFields ''TenantPoly) +$(makeLensesWith abbreviatedFields ''UserPoly) +$(makeLensesWith abbreviatedFields ''RolePoly) +$(makeAuditableLenses ''InternalTenant) +$(makeAuditableLenses ''InternalUser) +$(makeAuditableLenses ''InternalRole) diff --git a/SpockOpaleye/appcore/src/OpaleyeDef.hs b/SpockOpaleye/appcore/src/OpaleyeDef.hs new file mode 100644 index 0000000..04d342b --- /dev/null +++ b/SpockOpaleye/appcore/src/OpaleyeDef.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module OpaleyeDef where + +import Data.List.NonEmpty +import Data.Maybe +import Data.Profunctor.Product +import qualified Data.Profunctor.Product.Default as D +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import Data.Text +import Data.Text.Encoding +import Data.Time +import Database.PostgreSQL.Simple.FromField +import Opaleye + +import Control.Lens +import Data.Vector + +readOnly :: String -> TableProperties () (Column a) +readOnly = lmap (const Nothing) . optional + +userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) +userRolePivotTable = Table "users_roles" (p2 (required "user_id", required "role_id")) + +auditTable :: Table ( + () + , Column PGInt4 + , Maybe (Column (Nullable PGInt4)) + , Maybe (Column PGBool) + , Column PGInt4 + , Column PGText + , Column PGText + , Column PGJsonb + , Maybe (Column PGTimestamptz)) + ( + Column PGInt4 + , Column PGInt4 + , Column (Nullable PGInt4) + , Column PGBool + , Column PGInt4 + , Column PGText + , Column PGText + , Column PGJsonb + , Column PGTimestamptz) +auditTable = Table "audit_logs" (p9 ( + readOnly "id" + , required "tenant_id" + , optional "user_id" + , optional "changed_by_system" + , required "auditable_id" + , required "auditable_table_name" + , required "summary" + , required "changes" + , optional "created_at" + )) + +instance D.Default Constant () (Maybe (Column PGInt4)) where + def = Constant (\_ -> Nothing) + +instance D.Default Constant () (Maybe (Column PGText)) where + def = Constant (\_ -> Nothing) + +instance D.Default Constant Text (Column (Nullable PGText)) where + def = Constant (toNullable.pgStrictText) + +instance D.Default Constant () (Maybe (Column PGTimestamptz)) where + def = Constant (\() -> Nothing) + +instance D.Default Constant () (Column PGTimestamptz) where + def = Constant (\() -> pgUTCTime defaultutc) + where + defaultutc = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + +instance D.Default Constant UTCTime (Maybe (Column PGTimestamptz)) where + def = Constant (\time -> Just $ pgUTCTime time) + +instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where + queryRunnerColumnDefault = fieldQueryRunnerColumn diff --git a/SpockOpaleye/appcore/src/Role/RoleApi.hs b/SpockOpaleye/appcore/src/Role/RoleApi.hs new file mode 100644 index 0000000..15a1640 --- /dev/null +++ b/SpockOpaleye/appcore/src/Role/RoleApi.hs @@ -0,0 +1,13 @@ +module RoleApi where + +import Control.Monad.IO.Class +import Control.Lens +import UserDefs +import ApiBase +import AppM +import Utils +import Lenses + +createRole :: RoleIncoming -> AppM Role +createRole role = auditable <$> createRow roleTable role + diff --git a/SpockOpaleye/appcore/src/Role/RoleDefs.hs b/SpockOpaleye/appcore/src/Role/RoleDefs.hs new file mode 100644 index 0000000..6a5b420 --- /dev/null +++ b/SpockOpaleye/appcore/src/Role/RoleDefs.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module RoleDefs where + +import Database.PostgreSQL.Simple.FromField +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Control.Lens +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import OpaleyeDef +import TenantId +import Data.Text +import Data.Maybe +import Data.List.NonEmpty +import Data.Time (UTCTime) +import Data.Aeson +import Data.Vector +import Data.Aeson.Types +import Data.Text.Encoding +import Auditable + +newtype RoleId = RoleId Int + deriving (Show) + +data RolePoly key tenant_id name permission created_at updated_at = Role { + _rolepolyId :: key + , _rolepolyTenantid :: tenant_id + , _rolepolyName :: name + , _rolepolyPermission :: permission + , _rolepolyCreatedat :: created_at + , _rolepolyUpdatedat :: updated_at +} deriving (Show) + +$(makeAdaptorAndInstance "pRole" ''RolePoly) + +type InternalRole = RolePoly RoleId TenantId Text (NonEmpty Permission) UTCTime UTCTime +type Role = Auditable InternalRole +type RoleIncoming = RolePoly () TenantId Text (NonEmpty Permission) () () + +type RoleTableW = RolePoly + () + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + +type RoleTableR = RolePoly + (Column PGInt4) + (Column PGInt4) + (Column PGText) + (Column (PGArray PGText)) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + +roleTable :: Table RoleTableW RoleTableR +roleTable = Table "roles" (pRole Role { + _rolepolyId = (readOnly "id"), + _rolepolyTenantid = required "tenant_id", + _rolepolyName = required "name", + _rolepolyPermission = required "permissions", + _rolepolyCreatedat = optional "created_at", + _rolepolyUpdatedat = required "updated_at" + }) + +instance D.Default Constant RoleId (Column PGInt4) where + def = Constant def' + where + def' :: RoleId -> (Column PGInt4) + def' (RoleId id') = pgInt4 id' + +instance D.Default Constant RoleId () where + def = Constant (\_ -> ()) + +instance FromField RoleId where + fromField f mdata = do + x <- fromField f mdata + return $ RoleId x + +instance QueryRunnerColumnDefault PGInt4 RoleId where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance D.Default Constant (NonEmpty Permission) (Column (PGArray PGText)) where + def = Constant def' + where + def' :: (NonEmpty Permission) -> (Column (PGArray PGText)) + def' (ph :| pl) = pgArray pgStrictText $ toText <$> (ph : pl) + where + toText :: Permission -> Text + toText Read = "Read" + toText Create = "Create" + toText Update = "Update" + toText Delete = "Delete" + +instance QueryRunnerColumnDefault (PGArray PGText) (NonEmpty Permission) where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromField Permission where + fromField _ mdata = return $ makePermission mdata + where + makePermission (Just x) = toPermission $ decodeUtf8 x + makePermission Nothing = error "No data read from db" + +toPermission :: Text -> Permission +toPermission "Read" = Read +toPermission "Create" = Create +toPermission "Update" = Update +toPermission "Delete" = Delete +toPermission _ = error "Unrecognized permission" + +instance FromField [Permission] where + fromField f mdata = (fmap toPermission) <$> Data.Vector.toList <$> fromField f mdata + +instance FromField (NonEmpty Permission) where + fromField f mdata = (fromJust.nonEmpty) <$> (fromField f mdata) + +instance QueryRunnerColumnDefault PGText Permission where + queryRunnerColumnDefault = fieldQueryRunnerColumn +-- + +data Permission = Read | Create | Update | Delete + deriving (Show) + +instance ToJSON RoleId where + toJSON (RoleId x) = toJSON x + +instance ToJSON Permission where + toJSON x = toJSON $ show x + +instance (ToJSON a) => ToJSON (Auditable a) where + toJSON Auditable {_data = x} = toJSON x diff --git a/SpockOpaleye/appcore/src/Tenant/TenantApi.hs b/SpockOpaleye/appcore/src/Tenant/TenantApi.hs new file mode 100644 index 0000000..74aae4d --- /dev/null +++ b/SpockOpaleye/appcore/src/Tenant/TenantApi.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module TenantApi where + +import Control.Monad.IO.Class +import Control.Lens +import TenantDefs +import ApiBase +import AppM +import Utils +import Lenses +import CryptoDef + +createTenant :: TenantIncoming -> AppM Tenant +createTenant tenant = do + auditable <$> createRow tenantTable tenant diff --git a/SpockOpaleye/appcore/src/Tenant/TenantDefs.hs b/SpockOpaleye/appcore/src/Tenant/TenantDefs.hs new file mode 100644 index 0000000..5034794 --- /dev/null +++ b/SpockOpaleye/appcore/src/Tenant/TenantDefs.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module TenantDefs where + +import Database.PostgreSQL.Simple.FromField hiding (name) +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Control.Lens +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import OpaleyeDef +import GHC.Generics +import Data.Time +import Data.Text +import UserId +import TenantId +import Data.Aeson +import Data.Aeson.Types +import Data.Char +import Auditable +import Prelude hiding(id) +import qualified Data.HashMap.Strict as HM +import Utils + +data TenantPoly key created_at updated_at name fname lname email phone status owner_id b_domain = Tenant { + _tenantpolyId :: key + , _tenantpolyCreatedat :: created_at + , _tenantpolyUpdatedat :: updated_at + , _tenantpolyName :: name + , _tenantpolyFirstname :: fname + , _tenantpolyLastname :: lname + , _tenantpolyEmail :: email + , _tenantpolyPhone :: phone + , _tenantpolyStatus :: status + , _tenantpolyOwnerid :: owner_id + , _tenantpolyBackofficedomain :: b_domain +} deriving (Show, Generic) + + +data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew + deriving (Show, Generic) + +type InternalTenant = TenantPoly TenantId UTCTime UTCTime Text Text Text Text Text TenantStatus (Maybe UserId) Text + +type Tenant = Auditable InternalTenant + +type TenantTableW = TenantPoly + () + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Maybe (Column PGText)) + (Maybe (Column (Nullable PGInt4))) + (Column PGText) + +type TenantTableR = TenantPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column PGText) + (Column (Nullable PGInt4)) + (Column PGText) + +$(makeAdaptorAndInstance "pTenant" ''TenantPoly) + +tenantTable :: Table TenantTableW TenantTableR +tenantTable = Table "tenants" (pTenant + Tenant { + _tenantpolyId = (readOnly "id"), + _tenantpolyCreatedat = (optional "created_at"), + _tenantpolyUpdatedat = (required "updated_at"), + _tenantpolyName = (required "name"), + _tenantpolyFirstname = (required "first_name"), + _tenantpolyLastname = (required "last_name"), + _tenantpolyEmail = (required "email"), + _tenantpolyPhone = (required "phone"), + _tenantpolyStatus = (optional "status"), + _tenantpolyOwnerid = (optional "owner_id"), + _tenantpolyBackofficedomain = (required "backoffice_domain") + } + ) + +getTestTenant :: Tenant +getTestTenant = auditable $ Tenant (TenantId 1) tz tz "tjhon" "John" "Jacob" "john@gmail.com" "2342424" TenantStatusNew Nothing "Bo domain" + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + +type TenantIncoming = TenantPoly () () () Text Text Text Text Text () (Maybe UserId) Text + +instance D.Default Constant TenantStatus (Maybe (Column PGText)) where + def = Constant def' + where + def' :: TenantStatus -> (Maybe (Column PGText)) + def' TenantStatusInActive = Just $ pgStrictText "inactive" + def' TenantStatusActive = Just $ pgStrictText "active" + def' TenantStatusNew = Just $ pgStrictText "new" + +instance FromField TenantStatus where + fromField _ mdata = return tStatus + where + tStatus = + case mdata of + Just "active" -> TenantStatusActive + Just "inactive" -> TenantStatusInActive + Just "new" -> TenantStatusNew + _ -> error "Bad value read for user status" + +instance QueryRunnerColumnDefault PGText TenantStatus where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromJSON TenantStatus where + parseJSON j@(String _) = tStatus <$> (parseJSON j) + where + tStatus :: Text -> TenantStatus + tStatus "active" = TenantStatusActive + tStatus "inactive" = TenantStatusInActive + tStatus "new" = TenantStatusNew + tStatus _ = error "Unknown status name while parsing TenantStatus field" + parseJSON invalid = typeMismatch "TenantStatus" invalid + +instance FromJSON TenantIncoming where + parseJSON (Object v) = + (Tenant () () ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> + v .: "email" <*> + v .: "phone" <*> + (pure ()) <*> + v .: "userId" <*> + v .: "backofficeDomain" + parseJSON invalid = typeMismatch "Unexpected type while paring TenantIncoming" invalid + +instance ToJSON TenantStatus where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = tgModify } + where + tgModify :: String -> String + tgModify "TenantStatusActive" = "active" + tgModify "TenantStatusInActive" = "inactive" + tgModify "TenantStatusNew" = "new" + tgModify _ = error "Unknown status name for tenant" + +instance ToJSON InternalTenant where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = (fmap Data.Char.toLower).removePrefix } + where + removePrefix = Prelude.drop 11 + diff --git a/SpockOpaleye/appcore/src/Tenant/TenantId.hs b/SpockOpaleye/appcore/src/Tenant/TenantId.hs new file mode 100644 index 0000000..cb63d13 --- /dev/null +++ b/SpockOpaleye/appcore/src/Tenant/TenantId.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module TenantId where + +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Database.PostgreSQL.Simple.FromField +import Data.Aeson +import Data.Aeson.Types +import GHC.Generics + +newtype TenantId = TenantId Int + deriving (Show, Generic) + +instance D.Default Constant TenantId (Column PGInt4) where + def = Constant def' + where + def' :: TenantId -> (Column PGInt4) + def' (TenantId id') = pgInt4 id' + +instance D.Default Constant TenantId () where + def = Constant (\_ -> ()) + +instance FromField TenantId where + fromField f mdata = do + x <- fromField f mdata + return $ TenantId x + +instance QueryRunnerColumnDefault PGInt4 TenantId where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromJSON TenantId where + parseJSON j@(Number _) = TenantId <$> (parseJSON j) + parseJSON invalid = typeMismatch "TenantId" invalid + +instance ToJSON TenantId where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions diff --git a/SpockOpaleye/appcore/src/User/UserApi.hs b/SpockOpaleye/appcore/src/User/UserApi.hs new file mode 100644 index 0000000..4b8c295 --- /dev/null +++ b/SpockOpaleye/appcore/src/User/UserApi.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module UserApi where + +import Control.Monad.IO.Class +import Control.Lens +import UserDefs +import ApiBase +import AppM +import Utils +import Lenses +import CryptoDef + +createUser :: UserIncoming -> AppM User +createUser user = do + Just hash <- liftIO $ bcryptPassword $ user ^. password + let fullUser = user { _userpolyPassword = hash } + auditable <$> (createRow userTable fullUser) diff --git a/SpockOpaleye/appcore/src/User/UserDefs.hs b/SpockOpaleye/appcore/src/User/UserDefs.hs new file mode 100644 index 0000000..9c7d76e --- /dev/null +++ b/SpockOpaleye/appcore/src/User/UserDefs.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module UserDefs where + +import Database.PostgreSQL.Simple.FromField +import qualified Data.Profunctor.Product.Default as D +import Opaleye +import Control.Lens +import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import Data.Time +import OpaleyeDef +import GHC.Generics +import Data.Text +import CryptoDef +import TenantId +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM +import Auditable +import Data.Char +import Prelude hiding (id) +import UserId +import Utils + +data UserPoly key created_at updated_at tenant_id username password firstname lastname status = User { + _userpolyId :: key + , _userpolyCreatedat :: created_at + , _userpolyUpdatedat :: updated_at + , _userpolyTenantid :: tenant_id + , _userpolyUsername :: username + , _userpolyPassword :: password + , _userpolyFirstname :: firstname + , _userpolyLastname :: lastname + , _userpolyStatus :: status +} deriving (Show) + +type UserTableW = UserPoly + () + (Maybe (Column PGTimestamptz)) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Maybe (Column (Nullable PGText))) + (Maybe (Column (Nullable PGText))) + (Maybe (Column PGText)) + +type UserTableR = UserPoly + (Column PGInt4) + (Column PGTimestamptz) -- createdAt + (Column PGTimestamptz) -- updatedAt + (Column PGInt4) + (Column PGText) + (Column PGBytea) + (Column (Nullable PGText)) + (Column (Nullable PGText)) + (Column PGText) + + +$(makeAdaptorAndInstance "pUser" ''UserPoly) + +userTable :: Table UserTableW UserTableR +userTable = Table "users" (pUser + User { + _userpolyId = (readOnly "id") + , _userpolyCreatedat = (optional "created_at") + , _userpolyUpdatedat = (required "updated_at") + , _userpolyTenantid = required "tenant_id" + , _userpolyUsername = required "username" + , _userpolyPassword = required "password" + , _userpolyFirstname = optional "first_name" + , _userpolyLastname = optional "last_name" + , _userpolyStatus = optional "status" + }) + +data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked + deriving (Show) + +type InternalUser = UserPoly UserId UTCTime UTCTime TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus +type User = Auditable InternalUser + +getTestUser :: IO User +getTestUser = do + Just password_ <- bcryptPassword "adsasda" + return $ auditable $ User (UserId 1) tz tz (TenantId 1) "John" password_ (Just "2342424") (Just "asdada") UserStatusActive + where + tz = UTCTime { + utctDay = ModifiedJulianDay { + toModifiedJulianDay = 0 + } + , utctDayTime = secondsToDiffTime 0 + } + +type UserIncoming = UserPoly () () () TenantId Text Text (Maybe Text) (Maybe Text) () + +instance D.Default Constant UserStatus (Maybe (Column PGText)) where + def = Constant def' + where + def' :: UserStatus -> Maybe (Column PGText) + def' UserStatusInActive = Just $ pgStrictText "inactive" + def' UserStatusActive = Just $ pgStrictText "active" + def' UserStatusBlocked = Just $ pgStrictText "blocked" + +instance FromField (UserStatus) where + fromField _ mdata = return gender + where + gender = + case mdata of + Just "active" -> UserStatusActive + Just "inactive" -> UserStatusInActive + Just "blocked" -> UserStatusBlocked + _ -> error "Bad value read for user status" + +instance QueryRunnerColumnDefault PGText UserStatus where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance ToJSON UserStatus where + toJSON x = String $ Data.Text.pack $ show x diff --git a/SpockOpaleye/appcore/src/User/UserId.hs b/SpockOpaleye/appcore/src/User/UserId.hs new file mode 100644 index 0000000..6db8f57 --- /dev/null +++ b/SpockOpaleye/appcore/src/User/UserId.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module UserId where + +import Database.PostgreSQL.Simple.FromField +import Opaleye +import qualified Data.Profunctor.Product.Default as D +import GHC.Generics + +import Data.Aeson +import Data.Aeson.Types + +newtype UserId = UserId Int + deriving (Show, Generic) + +instance D.Default Constant (UserId) (Column PGInt4) where + def = Constant def' + where + def' :: UserId -> (Column PGInt4) + def' (UserId id') = pgInt4 id' + +instance D.Default Constant UserId () where + def = Constant (\_ -> ()) + +instance D.Default Constant (UserId) (Column (Nullable PGInt4)) where + def = Constant def' + where + def' :: UserId -> (Column (Nullable PGInt4)) + def' (UserId id') = (toNullable.pgInt4) id' + +instance FromField UserId where + fromField f mdata = do + x <- fromField f mdata + return $ UserId x + +instance QueryRunnerColumnDefault PGInt4 UserId where + queryRunnerColumnDefault = fieldQueryRunnerColumn + +instance FromJSON UserId where + parseJSON j@(Number _) = UserId <$> (parseJSON j) + parseJSON invalid = typeMismatch "UserId" invalid + +instance ToJSON UserId where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions diff --git a/SpockOpaleye/appcore/src/Utils.hs b/SpockOpaleye/appcore/src/Utils.hs new file mode 100644 index 0000000..b66e48b --- /dev/null +++ b/SpockOpaleye/appcore/src/Utils.hs @@ -0,0 +1,12 @@ +module Utils where + +import Auditable +import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM + +auditable :: a -> Auditable a +auditable a = Auditable {_data = a, _log = Object HM.empty} + +wrapAuditable :: (Functor a, Functor b) => a (b c) -> a (b (Auditable c)) +wrapAuditable a = (fmap auditable) <$> a + diff --git a/SpockOpaleye/appcore/stack.yaml b/SpockOpaleye/appcore/stack.yaml new file mode 100644 index 0000000..0706908 --- /dev/null +++ b/SpockOpaleye/appcore/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-7.13 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.2" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/SpockOpaleye/appcore/test/Spec.hs b/SpockOpaleye/appcore/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/SpockOpaleye/appcore/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/SpockOpaleye/apple.png b/SpockOpaleye/apple.png new file mode 100644 index 0000000..406679d Binary files /dev/null and b/SpockOpaleye/apple.png differ diff --git a/SpockOpaleye/db/bootstrap.sql b/SpockOpaleye/db/bootstrap.sql new file mode 100644 index 0000000..c841afa --- /dev/null +++ b/SpockOpaleye/db/bootstrap.sql @@ -0,0 +1,2 @@ +insert into tenants values (default, default, default, 'BTenant', 'B', 'Tenant', 'tenant@hw.com', '2312342', 'inactive', null, 'bo-domain'); +insert into users values (default, default, default, 1, 'BUser', 'password', 'B', 'User', 'inactive'); diff --git a/SpockOpaleye/db/schema.sql b/SpockOpaleye/db/schema.sql new file mode 100644 index 0000000..5881d14 --- /dev/null +++ b/SpockOpaleye/db/schema.sql @@ -0,0 +1,220 @@ +-- +-- Tenants +-- + +create type tenant_status as enum('active', 'inactive', 'new'); +create table tenants( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,name text not null + ,first_name text not null + ,last_name text not null + ,email text not null + ,phone text not null + ,status tenant_status not null default 'inactive' + ,owner_id integer + ,backoffice_domain text not null + constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null) +); +create unique index idx_index_owner_id on tenants(owner_id); +create index idx_status on tenants(status); +create index idx_tenants_created_at on tenants(created_at); +create index idx_tenants_updated_at on tenants(updated_at); +create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain)); + +-- +-- Users +-- + +create type user_status as enum('active', 'inactive', 'blocked'); +create table users( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,tenant_id integer not null references tenants(id) + ,username text not null + ,password text not null + ,first_name text + ,last_name text + ,status user_status not null default 'inactive' +); + +create unique index idx_users_username on users(lower(username)); +create index idx_users_created_at on users(created_at); +create index idx_users_updated_at on users(updated_at); +create index idx_users_status on users(status); + +alter table tenants + add constraint fk_tenants_owner_id + foreign key (owner_id) + references users(id); + +-- +-- Roles +-- +-- TODO: Write a CHECK CONSTRAINT that ensures that permissions[] contains only +-- those permissions that the Haskell ADT can recognize + +create table roles( + id serial primary key + ,tenant_id integer not null references tenants(id) + ,name text not null + ,permissions text[] not null constraint at_least_one_permission check (array_length(permissions, 1)>0) + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp +); +create unique index idx_roles_name on roles(tenant_id, lower(name)); +create index idx_roles_created_at on roles(created_at); +create index idx_roles_updated_at on roles(updated_at); + +-- +-- User<>roles +-- +-- Join-through table between users and roles +-- + +create table users_roles( + user_id integer not null references users(id) + ,role_id integer not null references roles(id) +); +create unique index idx_users_roles on users_roles(user_id, role_id); + + +-- +-- Audit log +-- + +create table audit_logs( + id serial primary key + ,tenant_id integer not null references tenants(id) + ,user_id integer references users(id) + ,changed_by_system boolean not null default false + ,auditable_id integer not null + ,auditable_table_name text not null + ,summary text not null + ,changes jsonb not null + ,created_at timestamp with time zone not null default current_timestamp + constraint ensure_user_id check ((user_id is not null and not changed_by_system) or (user_id is null and changed_by_system)) +); +create index idx_audit_logs_auditable_row on audit_logs(auditable_id, auditable_table_name); +create index idx_audit_logs_tenant_user_id on audit_logs(tenant_id, user_id); +create index idx_audit_logs_created_at on audit_logs(created_at); +-- TODO: index on audit_logs(changes)? + +-- +-- Products +-- +-- TODO: Evolve this schema to have a "price on request" feature. Evolve this +-- say whether the comparison_price is computed automatically or manually set by +-- the user. +-- +-- TODO: do we need an is_deleted housekeeping column in every table? Is that +-- really required, given that we have an audit log? + +create type product_type as enum('physical', 'digital'); +create table products( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,tenant_id integer not null references tenants(id) + ,name text not null + ,description text + ,url_slug text not null + ,tags text[] not null default '{}' + ,currency char(3) not null + ,advertised_price numeric not null + ,comparison_price numeric not null + + -- NOTE: Adding the cost-price as an optional column to make the JSON + -- responses dependent upon the persmission of the signed-in user. + ,cost_price numeric + ,type product_type not null + ,is_published boolean not null default false + ,properties jsonb +); + +create unique index idx_products_name on products(tenant_id, lower(name)); +create unique index idx_products_url_sluf on products(tenant_id, lower(url_slug)); +create index idx_products_created_at on products(created_at); +create index idx_products_updated_at on products(updated_at); +create index idx_products_comparison_price on products(comparison_price); +create index idx_products_tags on products using gin(tags); +create index idx_product_type on products(type); +create index idx_product_is_published on products(is_published); + +-- +-- Variants +-- + +create type weight_unit as enum('grams', 'kgs', 'pounds'); +create table variants( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + ,updated_at timestamp with time zone not null default current_timestamp + ,tenant_id integer not null references tenants(id) + ,product_id integer not null references products(id) + ,name text not null + ,sku text not null + ,currency char(3) not null + ,price numeric not null + ,quantity integer + ,weight_in_grams integer + ,weight_display_unit weight_unit +); + +-- TODO: Do we need an index on variants(tenant_id) & varianta(product_id) +create index idx_variants_created_at on variants(created_at); +create index idx_variants_updated_at on variants(updated_at); + +create function check_weight_reqd_for_physical_products() returns trigger as $$ + declare + ptype product_type; + begin + select type into ptype from products where id=new.product_id; + if (ptype='physical') and (weight_in_grams is null or weight_display_unit is null) then + raise exception 'weight_in_grams and weight_display_unit, both, should be set only for physical products'; + end if; + + return new; + end; +$$ language plpgsql; + +create constraint trigger trig_weight_reqd_for_physical_products + after insert or update on variants + deferrable initially deferred + for each row + -- when ((new.weight_in_grams is not null) or (new.weight_display_unit is not null)) + execute procedure check_weight_reqd_for_physical_products(); + +-- TODO: Need a trigger-contraint to ensure that, if the product-type is chaged +-- to 'physical' then weights have been added to variants. This raises the +-- question about what is a better approach in DB design? +-- +-- 1. Different triggers for every such condition, or +-- +-- 2. One unified 'validation' trigger that will be fired anytime a row in +-- products, variants, images, or any other related table is created, updated, +-- or deleted? +-- +-- It seem (2) is more in line with the Haskell philosophy, i.e. +-- idempotent/stateless actions. + +create table photos( + id serial primary key + ,created_at timestamp with time zone not null default current_timestamp + -- no updated_at on purpose + ,tenant_id integer not null references tenants(id) + ,product_id integer references products(id) + ,variant_id integer references variants(id) + ,file_size integer not null + ,file_type integer not null + ,file_original_path text not null + ,processed_styles jsonb + ,fingerprint text not null + constraint ensure_photo_reference check (product_id is not null or variant_id is not null) +); +create index idx_photos_created_at on photos(created_at); +create index idx_photos_fingerprint on photos(fingerprint); +create index idx_photos_variant_id on photos(variant_id); +create index idx_photos_product_id on photos(product_id); diff --git a/SpockOpaleye/email-templates/tenant-activation-text.tpl b/SpockOpaleye/email-templates/tenant-activation-text.tpl new file mode 100644 index 0000000..8738cba --- /dev/null +++ b/SpockOpaleye/email-templates/tenant-activation-text.tpl @@ -0,0 +1,7 @@ +Hi, + Thank you for your registration. You can login +at www.abc.com using your username and password. +Hope to see you soon. + +Regards, +abc.com diff --git a/SpockOpaleye/email-templates/tenant-activation.tpl b/SpockOpaleye/email-templates/tenant-activation.tpl new file mode 100644 index 0000000..b661524 --- /dev/null +++ b/SpockOpaleye/email-templates/tenant-activation.tpl @@ -0,0 +1,327 @@ + + + + + + Simple Transactional Email + + + + + + + + + +
  +
+ + + Activation Email. + + + + + + + + +
+ + + + + +
+

Hi there,

+

This is the activation link that you can use to verify your email.

+ + + + + + +
+ + + + + + +
Click here to activate
+
+
+
+ + + + + +
+ 		 
+ + + diff --git a/SpockOpaleye/hs-airbrake/.gitignore b/SpockOpaleye/hs-airbrake/.gitignore new file mode 100644 index 0000000..9a14ea8 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/.gitignore @@ -0,0 +1,4 @@ +dist +.cabal-sandbox +cabal.sandbox.config +result diff --git a/SpockOpaleye/hs-airbrake/.travis.yml b/SpockOpaleye/hs-airbrake/.travis.yml new file mode 100644 index 0000000..4196689 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/.travis.yml @@ -0,0 +1,8 @@ +language: haskell + +install: + - cabal update + - cabal install --only-dependencies + +script: + - cabal test diff --git a/SpockOpaleye/hs-airbrake/LICENSE b/SpockOpaleye/hs-airbrake/LICENSE new file mode 100644 index 0000000..3f8829d --- /dev/null +++ b/SpockOpaleye/hs-airbrake/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Joel Taylor +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/SpockOpaleye/hs-airbrake/README.md b/SpockOpaleye/hs-airbrake/README.md new file mode 100644 index 0000000..e20c580 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/README.md @@ -0,0 +1 @@ +[![Build status](https://travis-ci.org/pikajude/hs-airbrake.svg)](http://travis-ci.org/pikajude/hs-airbrake) diff --git a/SpockOpaleye/hs-airbrake/Setup.hs b/SpockOpaleye/hs-airbrake/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/SpockOpaleye/hs-airbrake/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SpockOpaleye/hs-airbrake/airbrake.cabal b/SpockOpaleye/hs-airbrake/airbrake.cabal new file mode 100644 index 0000000..2d572a8 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/airbrake.cabal @@ -0,0 +1,35 @@ +name: airbrake +version: 0.2.0.0 +synopsis: An Airbrake notifier for Haskell +description: Airbrake notifier. +homepage: https://github.com/joelteon/airbrake +license: BSD3 +license-file: LICENSE +author: Joel Taylor +maintainer: me@joelt.io +category: Network +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Airbrake, Airbrake.WebRequest, Airbrake.Credentials + other-modules: Paths_airbrake + build-depends: base == 4.* + , blaze-markup + , bytestring + , directory + , exceptions + , filepath + , http-conduit + , monad-control + , network >= 2.6 + , network-uri + , semigroups + , template-haskell + , text + , transformers + , utf8-string + , wai + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 diff --git a/SpockOpaleye/hs-airbrake/default.nix b/SpockOpaleye/hs-airbrake/default.nix new file mode 100644 index 0000000..cfa6a66 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/default.nix @@ -0,0 +1,18 @@ +{ mkDerivation, base, blaze-markup, bytestring, directory +, exceptions, filepath, http-conduit, monad-control, network +, network-uri, semigroups, stdenv, template-haskell, text +, transformers, utf8-string, wai +}: +mkDerivation { + pname = "airbrake"; + version = "0.2.0.0"; + src = ./.; + libraryHaskellDepends = [ + base blaze-markup bytestring directory exceptions filepath + http-conduit monad-control network network-uri semigroups + template-haskell text transformers utf8-string wai + ]; + homepage = "https://github.com/joelteon/airbrake"; + description = "An Airbrake notifier for Haskell"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/SpockOpaleye/hs-airbrake/release.nix b/SpockOpaleye/hs-airbrake/release.nix new file mode 100644 index 0000000..1cf6bbf --- /dev/null +++ b/SpockOpaleye/hs-airbrake/release.nix @@ -0,0 +1,15 @@ +{ supportedPlatforms ? [ "x86_64-linux" "x86_64-darwin" ] +, supportedCompilers ? ["ghc6104" "ghc6123" "ghc704" "ghc722" "ghc742" "ghc763" "ghc783" "ghcHEAD"] +}: + +let + genAttrs = (import {}).lib.genAttrs; +in +{ + airbrake = genAttrs supportedCompilers (ghcVer: genAttrs supportedPlatforms (system: + let + pkgs = import { inherit system; }; + haskellPackages = pkgs.lib.getAttrFromPath ["haskellPackages_${ghcVer}"] pkgs; + in haskellPackages.callPackage ./default.nix {} + )); +} diff --git a/SpockOpaleye/hs-airbrake/src/Airbrake.hs b/SpockOpaleye/hs-airbrake/src/Airbrake.hs new file mode 100644 index 0000000..a4227f4 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/src/Airbrake.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- | Utilities for notifying Airbrake of errors. An 'Error' type is +-- provided; you can convert any instance of 'Exception' to an 'Error' +-- using 'toError', which uses the exception's 'Typeable' instance. +-- +-- Airbrake requires a stack trace for any reported exception, but stack +-- trace information isn't readily available for Haskell exceptions. +-- 'notifyQ' and 'notifyReqQ' are provided for the purpose of providing the +-- current file position as the stack trace. +module Airbrake ( + -- * Notifying + notify, notifyReq, + notifyQ, notifyReqQ, + + -- * Notification metadata + -- *** Location lists + NonEmpty (..), Location, Locations, + + -- *** Wrapping errors + toError, Error (..), + + -- * Configuration building + APIKey, Environment, + airbrakeConf, defaultApiEndpoint, + AirbrakeConf (..), + Server (..), + + -- * Convenience exports + module Airbrake.Credentials +) where + +import Airbrake.Credentials hiding (APIKey) +import qualified Airbrake.WebRequest as W +import Control.Exception +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Data.ByteString.Lazy (ByteString) +import Data.Foldable +import Data.List.NonEmpty +import Data.String +import Data.Text (pack) +import qualified Data.Text as T (Text) +import Data.Typeable (typeOf) +import Data.Version +import Language.Haskell.TH.Syntax hiding (report) +import Network.HTTP.Conduit +import qualified Paths_airbrake as P +import Prelude hiding (error) +import Text.Blaze +import Text.Blaze.Internal +import Text.Blaze.Renderer.Utf8 + +type APIKey = String +type Environment = String + +data Error = Error + { errorType :: T.Text + , errorDescription :: T.Text + } + +-- | Information to use when communicating with Airbrake. +data AirbrakeConf = AirbrakeConf + { acApiEndpoint :: String + , acApiKey :: APIKey + , acServer :: Server + } + +-- | Metadata about the server. +data Server = Server + { serverEnvironment :: Environment + , serverAppVersion :: Maybe Version + , serverRoot :: Maybe FilePath + } + +-- | A @(filename, line)@ pair. +type Location = (FilePath, Int) + +type Locations = NonEmpty Location + +-- | @"http:\/\/api.airbrake.io\/notifier_api\/v2\/notices"@ +defaultApiEndpoint :: String +defaultApiEndpoint = "http://api.airbrake.io/notifier_api/v2/notices" + +airbrakeConf :: APIKey -> Environment -> AirbrakeConf +airbrakeConf k env = + AirbrakeConf defaultApiEndpoint k (Server env Nothing Nothing) + +performNotify :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => Locations -> AirbrakeConf -> Maybe W.WebRequest -> Error -> m () +performNotify loc conf req e = do + let report = buildReport loc conf req e + req' <- parseUrl (acApiEndpoint conf) + let rq = req' { requestBody = RequestBodyLBS report, method = "POST" } + man <- liftIO $ newManager tlsManagerSettings + _ <- httpLbs rq man + return () + +-- | Notify Airbrake of an exception. +notify :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => AirbrakeConf -> Error -> Locations -> m () +notify conf e l = performNotify l conf Nothing e + +-- | Notify Airbrake of an exception, providing request metadata along with +-- it. +notifyReq :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => AirbrakeConf -> W.WebRequest -> Error -> Locations -> m () +notifyReq conf req e l = performNotify l conf (Just req) e + +-- | 'notify', fetching the current file location using Template Haskell. +-- +-- @ +-- $notifyQ :: ('MonadBaseControl' 'IO' m, 'MonadThrow' m, 'MonadIO' m) +-- => 'AirbrakeConf' -> 'Error' -> m () +-- @ +notifyQ :: Q Exp +notifyQ = do + Loc fn _ _ (st, _) _ <- qLocation + [| \ cc ee -> notify cc ee ((fn, st) :| []) |] + +-- | 'notifyReq', fetching the current file location using Template +-- Haskell. +-- +-- @ +-- $notifyReqQ :: ('MonadBaseControl' 'IO' m, 'MonadThrow' m, 'MonadIO' m, 'W.WebRequest' req) +-- => 'AirbrakeConf' -> req -> 'Error' -> m () +-- @ +notifyReqQ :: Q Exp +notifyReqQ = do + Loc fn _ _ (st, _) _ <- qLocation + [| \ cc r ee -> notifyReq cc r ee ((fn, st) :| []) |] + +-- | Convert any 'Exception' to an 'Error'. +toError :: Exception e => e -> Error +toError (toException -> SomeException e) = + Error (pack (show (typeOf e))) (pack (show e)) + +buildReport :: Locations -> AirbrakeConf -> Maybe W.WebRequest -> Error -> ByteString +buildReport locs conf req err = renderMarkup $ do + preEscapedText "" + notice ! nversion "2.3" $ do + api_key . toMarkup $ acApiKey conf + + notifier $ do + name "airbrake" + version . toMarkup $ showVersion P.version + url "http://hackage.haskell.org/package/airbrake" + + error $ do + class_ (toMarkup (errorType err)) + message (toMarkup (errorDescription err)) + backtrace $ forM_ locs $ \ (filename, line') -> + line ! file (toValue filename) + ! number (toValue line') + + forM_ req $ \ r -> request $ do + url (toMarkup . show $ W.requestUrl r) + forM_ (W.requestRoute r) $ \ rt -> component (toMarkup rt) + forM_ (W.requestAction r) $ \ act -> action (toMarkup act) + cgi_data . forM_ (W.requestOtherVars r) $ \ (k, v) -> + var ! key (toValue k) $ toMarkup v + + let serv = acServer conf + server_environment $ do + environment_name . toMarkup $ serverEnvironment serv + forM_ (serverAppVersion serv) $ \ v -> + app_version (toMarkup $ showVersion v) + + forM_ (serverRoot serv) $ \ v -> + project_root (toMarkup v) + where + notice = Parent "notice" "" + name = Parent "name" "" + notifier = Parent "notifier" "" + api_key = Parent "api-key" "" + version = Parent "version" "" + url = Parent "url" "" + class_ = Parent "class" "" + error = Parent "error" "" + message = Parent "message" "" + backtrace = Parent "backtrace" "" + line = Leaf "line" "" + file = attribute "file" " file=\"" + number = attribute "number" " number=\"" + server_environment = Parent "server-environment" "" + environment_name = Parent "environment-name" "" + app_version = Parent "app-version" "" + project_root = Parent "project-root" "" + request = Parent "request" "" + cgi_data = Parent "cgi-data" "" + action = Parent "action" "" + component = Parent "component" "" + var = Parent "var" "" + key = attribute "key" " key=\"" + nversion = attribute "version" " version=\"" diff --git a/SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs b/SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs new file mode 100644 index 0000000..6c311a1 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/src/Airbrake/Credentials.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +-- | Utilities for loading the API key from the environment. +module Airbrake.Credentials ( + APIKey, + credentialsDefaultFile, credentialsDefaultKey, + loadCredentialsFromFile, loadCredentialsFromEnv, + loadCredentialsFromEnvOrFile, loadCredentialsDefault +) where + +import Control.Monad (liftM) +import Control.Monad.IO.Class +import Data.List (find) +import System.Directory +import System.Environment +import System.FilePath + +#if __GLASGOW_HASKELL__ <= 708 +import Control.Applicative ((<$>)) +#endif + +type APIKey = String + +-- | The file where API credentials are loaded when using +-- 'loadCredentialsDefault'. +-- +-- Default: @$HOME/.airbrake-keys@ +credentialsDefaultFile :: MonadIO m => m FilePath +credentialsDefaultFile = liftIO $ liftM ( ".airbrake-keys") getHomeDirectory + +-- | The key to be used in the loaded API credentials file, when using +-- 'loadCredentialsDefault'. +-- +-- Default: @default@ +credentialsDefaultKey :: String +credentialsDefaultKey = "default" + +-- | Load API credentials from a text file given a key name. +-- +-- The file should consist of newline-separated credentials in the +-- following format: +-- +-- @keyName apiKey@ +loadCredentialsFromFile :: MonadIO m => FilePath -> String -> m (Maybe APIKey) +loadCredentialsFromFile file key = liftIO $ do + contents <- map words . lines <$> readFile file + return $ do + [_k, apikey] <- find (hasKey key) contents + return apikey + where + hasKey _ [] = False + hasKey k (k2 : _) = k == k2 + +-- | Load API credentials from the environment if possible, or alternately +-- from the default file with the default key name. +-- +-- Default file: @$HOME/.airbrake-keys@ +-- +-- Default key: @default@ +-- +-- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile'. +loadCredentialsDefault :: MonadIO m => m (Maybe APIKey) +loadCredentialsDefault = do + file <- credentialsDefaultFile + loadCredentialsFromEnvOrFile file credentialsDefaultKey + +-- | Load API credentials from the environment variable @AIRBRAKE_API_KEY@. +loadCredentialsFromEnv :: MonadIO m => m (Maybe APIKey) +loadCredentialsFromEnv = liftIO $ do + env <- getEnvironment + let lk = flip lookup env + key = lk "AIRBRAKE_API_KEY" + return key + +-- | Load API credentials from the environment, or, failing that, from the +-- given file with the given key name. +-- +-- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile'. +loadCredentialsFromEnvOrFile :: MonadIO m => FilePath -> String -> m (Maybe APIKey) +loadCredentialsFromEnvOrFile file key = do + envcr <- loadCredentialsFromEnv + case envcr of + Just cr -> return (Just cr) + Nothing -> loadCredentialsFromFile file key diff --git a/SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs b/SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs new file mode 100644 index 0000000..4a88544 --- /dev/null +++ b/SpockOpaleye/hs-airbrake/src/Airbrake/WebRequest.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A datatype representing the request attributes Airbrake wants to hear +-- about. Conversion functions are provided for: +-- +-- * wai +module Airbrake.WebRequest ( + WebRequest (..), waiRequestToRequest +) where + +import Data.ByteString.UTF8 (toString) +import Data.Maybe +import Network.URI +import qualified Network.Wai as Wai + +data WebRequest = WebRequest + { + -- | The request URL. + requestUrl :: URI + -- | Current route. + -- This is a carryover from Rails-style MVC and is optional. + , requestRoute :: Maybe String + -- | Controller action being used. + -- This is a carryover from Rails-style MVC and is optional. + , requestAction :: Maybe String + -- | Any other request metadata that you would like to include + -- (server name, user agent, etc.) + , requestOtherVars :: [(String, String)] + } deriving (Eq, Ord, Show) + +waiRequestToRequest :: Wai.Request -> WebRequest +waiRequestToRequest req = WebRequest{..} where + requestUrl = fromMaybe + (error "Failure producing URI from wai request.") + (parseURI uriS) + uriS = (if Wai.isSecure req then "https://" else "http://") + ++ show (Wai.remoteHost req) + ++ toString (Wai.rawPathInfo req) + ++ toString (Wai.rawQueryString req) + requestRoute = Nothing + requestAction = Nothing + requestOtherVars = catMaybes + [ k "Host" "HTTP_HOST" + , k "User-Agent" "HTTP_USER_AGENT" + , k "Referer" "HTTP_REFERER" + , k "Cookie" "HTTP_COOKIE" + , if Wai.isSecure req then Just ("HTTPS", "on") else Nothing] + where k hdr key = fmap (\ v -> (key, toString v)) + (lookup hdr (Wai.requestHeaders req)) diff --git a/SpockOpaleye/src/Conf.hs.template b/SpockOpaleye/src/Conf.hs.template new file mode 100644 index 0000000..34f20b6 --- /dev/null +++ b/SpockOpaleye/src/Conf.hs.template @@ -0,0 +1,6 @@ +module Conf where + +import Network.Mail.SMTP + +apikey :: Password +apikey = "--sendgrid-api-key--" diff --git a/SpockOpaleye/src/DataTypes.hs b/SpockOpaleye/src/DataTypes.hs deleted file mode 100644 index ae47f24..0000000 --- a/SpockOpaleye/src/DataTypes.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module DataTypes where - -import CryptoDef -import Data.List.NonEmpty -import Data.Text -import GHC.Generics - -data ValidationResult = Valid | Invalid - deriving (Eq, Show) - -newtype TenantId = TenantId Int - deriving (Show, Generic) - -data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew - deriving (Show, Generic) - -data TenantPoly key name fname lname email phone status owner_id b_domain = Tenant - { tenant_id :: key - , tenant_name :: name - , tenant_firstname :: fname - , tenant_lastname :: lname - , tenant_email :: email - , tenant_phone :: phone - , tenant_status :: status - , tenant_ownerid :: owner_id - , tenant_backofficedomain :: b_domain - } deriving (Show, Generic) - -type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus (Maybe UserId) Text - -type TenantIncoming = TenantPoly () Text Text Text Text Text () (Maybe UserId) Text - -data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked - deriving (Show) - -newtype UserId = UserId Int - deriving (Show, Generic) - -data UserPoly key tenant_id username password firstname lastname status = User { - user_id :: key, - user_tenantid :: tenant_id, - user_username :: username, - user_password :: password, - user_firstname :: firstname, - user_lastname :: lastname, - user_status :: status -} - -type User = UserPoly UserId TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus - -data Permission = Read | Create | Update | Delete - deriving (Show) - -newtype RoleId = RoleId Int - deriving (Show) - -data RolePoly key tenant_id name permission = Role - { role_id :: key - , role_tenantid :: tenant_id - , role_name :: name - , role_permission :: permission - } deriving (Show) - -type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) diff --git a/SpockOpaleye/src/Email.hs b/SpockOpaleye/src/Email.hs new file mode 100644 index 0000000..b542d02 --- /dev/null +++ b/SpockOpaleye/src/Email.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Email where + +import AppCore +import Network.Mail.Mime +import Network.Mail.SMTP hiding (simpleMail) + +import Conf (apikey) +import Control.Concurrent +import Control.Lens +import Data.ByteString hiding (putStrLn) +import Data.Monoid +import Data.String +import Data.String.Here +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.ByteString.Lazy as L +import System.FilePath (takeFileName) + +sendgridMail :: Mail -> IO () +sendgridMail mail = do + threadId <- forkIO $ sendMailWithLogin' "smtp.sendgrid.net" 587 "apikey" apikey mail + putStrLn $ show $ T.concat ["Sending mail from thread ", fromString $ show threadId] + +addLogo :: Mail -> IO Mail +addLogo mail = addAttachmentCid "image/png" "apple.png" "logocid@haskellwebapps.com" mail + +sendTenantActivationMail :: Tenant -> IO () +sendTenantActivationMail newTenant = do + makeMail from to activationLink >>= addLogo >>= sendgridMail + where + -- @TODO Make key random + key :: T.Text + key = "cmFuZG9tdyBlaXJqd28gZWlyandvZWlyaiB3b2VyaWpvd2Vpcmogb3F3ZWlyb3F3ZWl1aHIgb3dxZXVoaXJ3b2Vpcmggb3dldWZob2kgcmV1d2ZpcmVxdWZoaXFld3VyaG9wIHF3dWh3aQ==" + activationLink :: T.Text + activationLink = T.concat ["http://haskellwebapps.vacationlabs.com/activateTenantKey/", key] + from = Address { addressName = Just "VacationLabs", addressEmail = "webapps@vacationlabs.com"} + to = Address { addressName = Just $ T.concat [tenantFname, " ", tenantLname], addressEmail = tenantEmail} + tenantFname = (newTenant ^. firstname ) + tenantLname = (newTenant ^. lastname ) + tenantEmail = (newTenant ^. email ) + makeMail :: Address -> Address -> T.Text -> IO Mail + makeMail from to activationLink = simpleMail to from subject text (LT.fromStrict html) [] + where + subject = "Registration Email from abc.com" + text = [template|email-templates/tenant-activation-text.tpl|] + html :: T.Text + html = [template|email-templates/tenant-activation.tpl|] diff --git a/SpockOpaleye/src/JsonInstances.hs b/SpockOpaleye/src/JsonInstances.hs index c90e2a6..ebcac37 100644 --- a/SpockOpaleye/src/JsonInstances.hs +++ b/SpockOpaleye/src/JsonInstances.hs @@ -4,65 +4,13 @@ module JsonInstances where -import Control.Monad +import AppCore import Data.Aeson import Data.Aeson.Types +import Data.Char import Data.Text -import DataTypes -instance FromJSON UserId where - parseJSON j@(Number v) = UserId <$> (parseJSON j) - parseJSON invalid = typeMismatch "UserId" invalid +import qualified Data.HashMap.Strict as HM -instance FromJSON TenantId where - parseJSON j@(Number v) = TenantId <$> (parseJSON j) - parseJSON invalid = typeMismatch "TenantId" invalid - -instance FromJSON TenantStatus where - parseJSON j@(String v) = t_status <$> (parseJSON j) - where - t_status :: Text -> TenantStatus - t_status "active" = TenantStatusActive - t_status "inactive" = TenantStatusInActive - t_status "new" = TenantStatusNew - parseJSON invalid = typeMismatch "TenantStatus" invalid - -instance FromJSON TenantIncoming where - parseJSON (Object v) = - (Tenant ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> - v .: "email" <*> - v .: "phone" <*> - (pure ()) <*> - v .: "userId" <*> - v .: "backofficeDomain" - -instance ToJSON TenantStatus where - toJSON = genericToJSON defaultOptions - toEncoding = - genericToEncoding - defaultOptions - { constructorTagModifier = tg_modify - } - where - tg_modify :: String -> String - tg_modify "TenantStatusActive" = "active" - tg_modify "TenantStatusInActive" = "inactive" - tg_modify "TenantStatusNew" = "new" - -instance ToJSON Tenant where - toJSON = genericToJSON defaultOptions - toEncoding = - genericToEncoding - defaultOptions - { fieldLabelModifier = remove_prefix - } - where - remove_prefix = Prelude.drop 7 - -instance ToJSON UserId where - toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions - -instance ToJSON TenantId where - toJSON = genericToJSON defaultOptions - toEncoding = genericToEncoding defaultOptions +instance (FromJSON a) => FromJSON (Auditable a) where + parseJSON j = auditable <$> (parseJSON j) diff --git a/SpockOpaleye/src/Lib.hs b/SpockOpaleye/src/Lib.hs deleted file mode 100644 index d7e3b6b..0000000 --- a/SpockOpaleye/src/Lib.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -module Lib - ( - ) where diff --git a/SpockOpaleye/src/OpaleyeDef.hs b/SpockOpaleye/src/OpaleyeDef.hs deleted file mode 100644 index daa5c5e..0000000 --- a/SpockOpaleye/src/OpaleyeDef.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module OpaleyeDef where - -import Data.List.NonEmpty -import Data.Maybe -import Data.Profunctor.Product -import qualified Data.Profunctor.Product.Default as D -import Data.Profunctor.Product.TH (makeAdaptorAndInstance) -import Data.Text -import Data.Text.Encoding -import Database.PostgreSQL.Simple.FromField -import Opaleye - -import Control.Lens -import DataTypes - -type TenantTableW = TenantPoly - (Maybe (Column PGInt4)) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Maybe (Column (Nullable PGInt4))) - (Column PGText) - -type TenantTableR = TenantPoly - (Column PGInt4) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column PGText) - (Column (Nullable PGInt4)) - (Column PGText) - -$(makeAdaptorAndInstance "pTenant" ''TenantPoly) -$(makeLensesWith abbreviatedFields ''TenantPoly) - -tenantTable :: Table TenantTableW TenantTableR -tenantTable = Table "tenants" (pTenant - Tenant { - tenant_id = (optional "id"), - tenant_name = (required "name"), - tenant_firstname = (required "first_name"), - tenant_lastname = (required "last_name"), - tenant_email = (required "email"), - tenant_phone = (required "phone"), - tenant_status = (required "status"), - tenant_ownerid = (optional "owner_id"), - tenant_backofficedomain = (required "backoffice_domain") - } - ) - -type UserTableW = UserPoly - (Maybe (Column PGInt4)) - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Maybe (Column (Nullable PGText))) - (Maybe (Column (Nullable PGText))) - (Column PGText) - -type UserTableR = UserPoly - (Column PGInt4) - (Column PGInt4) - (Column PGText) - (Column PGBytea) - (Column (Nullable PGText)) - (Column (Nullable PGText)) - (Column PGText) - -$(makeAdaptorAndInstance "pUser" ''UserPoly) -$(makeLensesWith abbreviatedFields ''UserPoly) - -userTable :: Table UserTableW UserTableR -userTable = Table "users" (pUser - User { - user_id = optional "id" - , user_tenantid = required "tenant_id" - , user_username = required "username" - , user_password = required "password" - , user_firstname = optional "first_name" - , user_lastname = optional "last_name" - , user_status = required "status" - }) - -type RoleTableW = RolePoly - (Maybe (Column PGInt4)) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - -type RoleTableR = RolePoly - (Column PGInt4) - (Column PGInt4) - (Column PGText) - (Column (PGArray PGText)) - -$(makeAdaptorAndInstance "pRole" ''RolePoly) -$(makeLensesWith abbreviatedFields ''RolePoly) - -roleTable :: Table RoleTableW RoleTableR -roleTable = Table "roles" (pRole Role { - role_id = optional "id", - role_tenantid = required "tenant_id", - role_name = required "name", - role_permission = required "permissions"}) - -userRolePivotTable :: Table (Column PGInt4, Column PGInt4) (Column PGInt4, Column PGInt4) -userRolePivotTable = Table "users_roles" (p2 (required "user_id", required "role_id")) - -instance D.Default Constant TenantStatus (Column PGText) where - def = Constant def' - where - def' :: TenantStatus -> (Column PGText) - def' TenantStatusInActive = pgStrictText "inactive" - def' TenantStatusActive = pgStrictText "active" - def' TenantStatusNew = pgStrictText "new" - -instance FromField (TenantStatus) where - fromField f mdata = return tStatus - where - tStatus = - case mdata of - Just "active" -> TenantStatusActive - Just "inactive" -> TenantStatusInActive - Just "new" -> TenantStatusNew - _ -> error "Bad value read for user status" - -instance QueryRunnerColumnDefault PGText TenantStatus where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance D.Default Constant UserStatus (Column PGText) where - def = Constant def' - where - def' :: UserStatus -> (Column PGText) - def' UserStatusInActive = pgStrictText "inactive" - def' UserStatusActive = pgStrictText "active" - def' UserStatusBlocked = pgStrictText "blocked" - -instance FromField (UserStatus) where - fromField f mdata = return gender - where - gender = - case mdata of - Just "active" -> UserStatusActive - Just "inactive" -> UserStatusInActive - Just "blocked" -> UserStatusBlocked - _ -> error "Bad value read for user status" - -instance QueryRunnerColumnDefault PGText UserStatus where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance D.Default Constant (NonEmpty Permission) (Column (PGArray PGText)) where - def = Constant def' - where - def' :: (NonEmpty Permission) -> (Column (PGArray PGText)) - def' (ph :| pl) = pgArray pgStrictText $ to_text <$> (ph : pl) - where - to_text :: Permission -> Text - to_text Read = "Read" - to_text Create = "Create" - to_text Update = "Update" - to_text Delete = "Delete" - -instance QueryRunnerColumnDefault (PGArray PGText) (NonEmpty Permission) where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance FromField Permission where - fromField f mdata = return $ makePermission mdata - where - makePermission (Just x) = toPermission $ decodeUtf8 x - makePermission Nothing = error "No data read from db" - -toPermission :: Text -> Permission -toPermission "Read" = Read -toPermission "Create" = Create -toPermission "Update" = Update -toPermission "Delete" = Delete -toPermission _ = error "Unrecognized permission" - -instance FromField [Permission] where - fromField field mdata = (fmap toPermission) <$> (splitByComma <$> fromField field mdata) - where - splitByComma :: Text -> [Text] - splitByComma = split (\x -> x == ',') - -instance FromField (NonEmpty Permission) where - fromField field mdata = (fromJust.nonEmpty) <$> (fromField field mdata) - -instance QueryRunnerColumnDefault PGText Permission where - queryRunnerColumnDefault = fieldQueryRunnerColumn - -instance D.Default Constant (UserId) (Column PGInt4) where - def = Constant def' - where - def' :: UserId -> (Column PGInt4) - def' (UserId id) = pgInt4 id - -instance FromField UserId where - fromField field mdata = do - x <- fromField field mdata - return $ UserId x - -instance QueryRunnerColumnDefault PGInt4 UserId where - queryRunnerColumnDefault = fieldQueryRunnerColumn - --- -instance D.Default Constant (RoleId) (Column PGInt4) where - def = Constant def' - where - def' :: RoleId -> (Column PGInt4) - def' (RoleId id) = pgInt4 id - -instance FromField RoleId where - fromField field mdata = do - x <- fromField field mdata - return $ RoleId x - -instance QueryRunnerColumnDefault PGInt4 RoleId where - queryRunnerColumnDefault = fieldQueryRunnerColumn - --- -instance D.Default Constant (TenantId) (Column PGInt4) where - def = Constant def' - where - def' :: TenantId -> (Column PGInt4) - def' (TenantId id) = pgInt4 id - -instance FromField TenantId where - fromField field mdata = do - x <- fromField field mdata - return $ TenantId x - -instance QueryRunnerColumnDefault PGInt4 TenantId where - queryRunnerColumnDefault = fieldQueryRunnerColumn diff --git a/SpockOpaleye/src/RoleAPi.hs b/SpockOpaleye/src/RoleAPi.hs index 313c483..4b26b52 100644 --- a/SpockOpaleye/src/RoleAPi.hs +++ b/SpockOpaleye/src/RoleAPi.hs @@ -5,51 +5,44 @@ {-# LANGUAGE OverloadedStrings #-} module RoleApi - ( create_role - , remove_role - , read_roles_for_tenant + ( + updateRole + , removeRole + , readRolesForTenant ) where +import AppCore import Control.Arrow -import Data.List.NonEmpty -import Data.Text -import Database.PostgreSQL.Simple (Connection) -import DataTypes import GHC.Int import Opaleye -import OpaleyeDef - -create_role :: Connection -> Role -> IO (Maybe Role) -create_role conn role@Role { role_tenantid = tenant_id , role_name = name , role_permission = rp } = do - ids <- - runInsertManyReturning - conn roleTable (return Role { - role_id = Nothing, - role_tenantid = constant tenant_id, - role_name = pgStrictText name, - role_permission = constant rp - }) id - return $ case ids of - [] -> Nothing - (x:xs) -> Just x - -remove_role :: Connection -> Role -> IO GHC.Int.Int64 -remove_role conn Role {role_id = t_id} = do - runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant t_id) - runDelete conn roleTable match_func +import Control.Lens +import Prelude hiding (id) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Strict as HM + + +updateRole :: Role -> AppM Role +updateRole role = updateAuditableRow roleTable role + +removeRole :: Role -> AppM GHC.Int.Int64 +removeRole role = do + _ <- removeRawDbRows userRolePivotTable (\(_, roleId) -> roleId .== constant (role ^. id)) + removeRawDbRows roleTable matchFunc where - match_func Role {role_id = id} = id .== constant t_id + tId = role ^. id + matchFunc role' = (role' ^. id).== constant tId -read_roles_for_tenant :: Connection -> TenantId -> IO [Role] -read_roles_for_tenant conn t_id = do - runQuery conn $ role_query_for_tenant t_id +readRolesForTenant :: TenantId -> AppM [Role] +readRolesForTenant tId = do + wrapAuditable $ readRow $ roleQueryForTenant tId -role_query :: Query RoleTableR -role_query = queryTable roleTable +roleQuery :: Query RoleTableR +roleQuery = queryTable roleTable -role_query_for_tenant :: TenantId -> Query RoleTableR -role_query_for_tenant t_tenantid = +roleQueryForTenant :: TenantId -> Query RoleTableR +roleQueryForTenant tTenantid = proc () -> - do row@ Role {role_tenantid = tenant_id } <- role_query -< () - restrict -< tenant_id .== (constant t_tenantid) - returnA -< row + do role <- roleQuery -< () + restrict -< (role ^. tenantid) .== (constant tTenantid) + returnA -< role diff --git a/SpockOpaleye/src/TenantApi.hs b/SpockOpaleye/src/TenantApi.hs index a743fab..fb7d73c 100644 --- a/SpockOpaleye/src/TenantApi.hs +++ b/SpockOpaleye/src/TenantApi.hs @@ -5,132 +5,77 @@ {-# LANGUAGE OverloadedStrings #-} module TenantApi - ( create_tenant - , read_tenants - , read_tenant_by_id - , read_tenant_by_backofficedomain - , remove_tenant - , update_tenant - , activate_tenant - , deactivate_tenant + ( createTenant + , readTenants + , readTenantById + , readTenantByBackofficedomain + , removeTenant + , updateTenant + , activateTenant + , deactivateTenant ) where +import AppCore import Control.Arrow +import Control.Lens +import Control.Monad.Reader +import Data.Maybe import Data.Text -import Database.PostgreSQL.Simple (Connection) -import DataTypes import GHC.Int import Opaleye -import OpaleyeDef +import Prelude hiding (id) import RoleApi import UserApi -create_tenant :: Connection -> TenantIncoming -> IO (Maybe Tenant) -create_tenant conn tenant@Tenant { - tenant_id = _ - ,tenant_name = name - ,tenant_firstname = first_name - ,tenant_lastname = last_name - ,tenant_email = email - ,tenant_phone = phone - ,tenant_status = _ - ,tenant_ownerid = owner_id - ,tenant_backofficedomain = bo_domain} = do - tenants <- runInsertManyReturning conn tenantTable (return Tenant { - tenant_id = Nothing - ,tenant_name = pgStrictText name - ,tenant_firstname = pgStrictText first_name - ,tenant_lastname = pgStrictText last_name - ,tenant_email = pgStrictText email - ,tenant_phone = pgStrictText phone - ,tenant_status = constant TenantStatusInActive - ,tenant_ownerid = toNullable . constant <$> owner_id - ,tenant_backofficedomain = pgStrictText bo_domain - }) id - return $ case tenants of - [] -> Nothing - (x:xs) ->Just x +activateTenant :: Tenant -> AppM Tenant +activateTenant tenant = setTenantStatus tenant TenantStatusActive -activate_tenant :: Connection -> Tenant -> IO Tenant -activate_tenant conn tenant = set_tenant_status conn tenant TenantStatusActive +deactivateTenant :: Tenant -> AppM Tenant +deactivateTenant tenant = setTenantStatus tenant TenantStatusInActive -deactivate_tenant :: Connection -> Tenant -> IO Tenant -deactivate_tenant conn tenant = set_tenant_status conn tenant TenantStatusInActive +setTenantStatus :: Tenant -> TenantStatus -> AppM Tenant +setTenantStatus tenant st = updateTenant (tenant & status .~ st) -set_tenant_status :: Connection -> Tenant -> TenantStatus -> IO Tenant -set_tenant_status conn tenant status = update_tenant conn (tenant_id tenant) - tenant { tenant_status = status } +updateTenant :: Tenant -> AppM Tenant +updateTenant tenant = do + updateAuditableRow tenantTable tenant -update_tenant :: Connection -> TenantId -> Tenant -> IO Tenant -update_tenant conn t_tenantid tenant@Tenant { - tenant_id = id - ,tenant_name = name - ,tenant_firstname = first_name - ,tenant_lastname = last_name - ,tenant_email = email - ,tenant_phone = phone - ,tenant_status = status - ,tenant_ownerid = owner_id - ,tenant_backofficedomain = bo_domain} = do - runUpdate conn tenantTable update_func match_func - return tenant +removeTenant :: Tenant -> AppM GHC.Int.Int64 +removeTenant tenant = do + tenant_deac <- deactivateTenant tenant + _ <- updateTenant (tenant_deac & ownerid .~ Nothing) + usersForTenant <- readUsersForTenant tid + rolesForTenant <- readRolesForTenant tid + mapM_ removeRole rolesForTenant + mapM_ removeUser usersForTenant + removeRawDbRows tenantTable matchFunc where - match_func :: TenantTableR -> Column PGBool - match_func Tenant { tenant_id = id } = id .== (constant t_tenantid) - update_func :: TenantTableR -> TenantTableW - update_func x = Tenant { - tenant_id = constant $ Just id - ,tenant_name = pgStrictText name - ,tenant_firstname = pgStrictText first_name - ,tenant_lastname = pgStrictText last_name - ,tenant_email = pgStrictText email - ,tenant_phone = pgStrictText phone - ,tenant_status = constant status - ,tenant_ownerid = toNullable . constant <$> owner_id - ,tenant_backofficedomain = pgStrictText bo_domain - } + tid = tenant ^. id + matchFunc :: TenantTableR -> Column PGBool + matchFunc tenant' = (tenant' ^. id) .== (constant tid) -remove_tenant :: Connection -> Tenant -> IO GHC.Int.Int64 -remove_tenant conn tenant@Tenant {tenant_id = tid} = do - deactivate_tenant conn tenant - update_tenant conn (tenant_id tenant) tenant { tenant_ownerid = Nothing } - users_for_tenant <- read_users_for_tenant conn tid - roles_for_tenant <- read_roles_for_tenant conn tid - mapM_ (remove_role conn) roles_for_tenant - mapM_ (remove_user conn) users_for_tenant - runDelete conn tenantTable match_func - where - match_func :: TenantTableR -> Column PGBool - match_func Tenant { tenant_id = id } = id .== (constant tid) - -read_tenants :: Connection -> IO [Tenant] -read_tenants conn = runQuery conn tenant_query +readTenants :: AppM [Tenant] +readTenants = wrapAuditable $ readRow tenantQuery -read_tenant_by_id :: Connection -> TenantId -> IO (Maybe Tenant) -read_tenant_by_id conn id = do - r <- runQuery conn $ (tenant_query_by_id id) - return $ case r of - [] -> Nothing - (x:xs) -> Just x +readTenantById :: TenantId -> AppM (Maybe Tenant) +readTenantById tenantId = do + wrapAuditable $ listToMaybe <$> (readRow (tenantQueryById tenantId)) -read_tenant_by_backofficedomain :: Connection -> Text -> IO (Maybe Tenant) -read_tenant_by_backofficedomain conn domain = do - r <- runQuery conn $ (tenant_query_by_backoffocedomain domain) - return $ case r of - [] -> Nothing - (x:xs) -> Just x +readTenantByBackofficedomain :: Text -> AppM (Maybe Tenant) +readTenantByBackofficedomain domain = do + wrapAuditable $ listToMaybe <$> (readRow (tenantQueryByBackoffocedomain domain)) -tenant_query :: Opaleye.Query TenantTableR -tenant_query = queryTable tenantTable +tenantQuery :: Opaleye.Query TenantTableR +tenantQuery = queryTable tenantTable -tenant_query_by_id :: TenantId -> Opaleye.Query TenantTableR -tenant_query_by_id t_id = proc () -> do - row@Tenant {tenant_id = id} <- tenant_query -< () - restrict -< id .== (constant t_id) - returnA -< row +tenantQueryById :: TenantId -> Opaleye.Query TenantTableR +tenantQueryById tId = proc () -> do + tenant <- tenantQuery -< () + restrict -< (tenant ^. id) .== (constant tId) + returnA -< tenant -tenant_query_by_backoffocedomain :: Text -> Opaleye.Query TenantTableR -tenant_query_by_backoffocedomain domain = proc () -> do - row@Tenant { tenant_backofficedomain = bo_domain } <- tenant_query -< () - restrict -< bo_domain .== (pgStrictText domain) - returnA -< row +tenantQueryByBackoffocedomain :: Text -> Opaleye.Query TenantTableR +tenantQueryByBackoffocedomain domain = proc () -> do + tenant <- tenantQuery -< () + restrict -< (tenant ^. backofficedomain) .== (pgStrictText domain) + returnA -< tenant diff --git a/SpockOpaleye/src/UserApi.hs b/SpockOpaleye/src/UserApi.hs index 6183ec5..a246690 100644 --- a/SpockOpaleye/src/UserApi.hs +++ b/SpockOpaleye/src/UserApi.hs @@ -5,135 +5,72 @@ {-# LANGUAGE OverloadedStrings #-} module UserApi - ( create_user - , read_users - , read_user_by_id - , read_users_for_tenant - , add_role_to_user - , remove_role_from_user - , update_user - , remove_user - , activate_user + ( createUser + , readUsers + , readUserById + , readUsersForTenant + , addRoleToUser + , removeRoleFromUser + , updateUser + , removeUser + , activateUser + , deactivateUser ) where +import AppCore import Control.Arrow -import Data.Text -import Database.PostgreSQL.Simple (Connection) -import DataTypes +import Control.Lens +import Control.Monad.IO.Class +import Data.Maybe import GHC.Int import Opaleye -import OpaleyeDef - -import CryptoDef - -create_user :: Connection -> User -> IO (Maybe User) -create_user conn user@User { - user_id = _ - ,user_tenantid = tenant_id - ,user_username = username - ,user_password = password - ,user_firstname = first_name - ,user_lastname = last_name - ,user_status = status - } = do - users <- - runInsertManyReturning conn userTable (return User { - user_id = Nothing - ,user_tenantid = constant tenant_id - ,user_username = pgStrictText username - ,user_password = constant password - ,user_firstname = toNullable . pgStrictText <$> first_name - ,user_lastname = toNullable . pgStrictText <$> last_name - ,user_status = constant status - }) id - return $ case users of - [] -> Nothing - (x:xs) -> Just x - -update_user :: Connection -> UserId -> User -> IO GHC.Int.Int64 -update_user conn (UserId tid) (User { - user_id = _ - ,user_tenantid = tenant_id - ,user_username = username - ,user_password = password - ,user_firstname = firstname - ,user_lastname = lastname - ,user_status = status }) = runUpdate conn userTable update_func match_func - where - update_func User { user_id = id } = User { - user_id = Just id - , user_tenantid = constant tenant_id - , user_username = pgStrictText username - , user_password = constant password - , user_firstname = toNullable . pgStrictText <$> firstname - , user_lastname = toNullable . pgStrictText <$> lastname - , user_status = constant status - } - match_func User { user_id = id } = id .== constant tid - -activate_user :: Connection -> User -> IO GHC.Int.Int64 -activate_user conn user = set_user_status conn user UserStatusActive - -deactivate_user :: Connection -> User -> IO GHC.Int.Int64 -deactivate_user conn user = set_user_status conn user UserStatusInActive - -set_user_status :: Connection -> User -> UserStatus -> IO GHC.Int.Int64 -set_user_status conn user@User { - user_id = id - ,user_tenantid = tid - ,user_username = username - ,user_password = password - ,user_firstname = firstname - ,user_lastname = lastname - ,user_status = status} new_status = update_user conn id User { user_id = id - ,user_tenantid = tid - ,user_username = username - ,user_password = password - ,user_firstname = firstname - ,user_lastname = lastname - ,user_status = new_status } - -remove_user :: Connection -> User -> IO GHC.Int.Int64 -remove_user conn User {user_id = tid} = - runDelete conn userTable match_function - where - match_function User { user_id = id } = id .== constant tid - -read_users :: Connection -> IO [User] -read_users conn = do - runQuery conn $ user_query - -read_users_for_tenant :: Connection -> TenantId -> IO [User] -read_users_for_tenant conn tenant_id = do - r <- runQuery conn $ user_query_by_tenantid tenant_id - return r - -read_user_by_id :: Connection -> UserId -> IO (Maybe User) -read_user_by_id conn id = do - r <- runQuery conn $ user_query_by_id id - return $ case r of - [] -> Nothing - (x:xs) -> Just x - -add_role_to_user :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 -add_role_to_user conn user_id role_id = - runInsertMany conn userRolePivotTable (return (constant user_id, constant role_id)) - -remove_role_from_user :: Connection -> UserId -> RoleId -> IO GHC.Int.Int64 -remove_role_from_user conn t_user_id t_role_id = runDelete conn userRolePivotTable - (\(user_id, role_id) -> (user_id .== constant t_user_id) .&& (role_id .== constant t_role_id)) - -user_query :: Query UserTableR -user_query = queryTable userTable - -user_query_by_id :: UserId -> Query UserTableR -user_query_by_id t_id = proc () -> do - row@User{user_id = id} <- user_query -< () - restrict -< id .== (constant t_id) - returnA -< row - -user_query_by_tenantid :: TenantId -> Query UserTableR -user_query_by_tenantid t_tenantid = proc () -> do - row@User {user_tenantid = tenant_id} <- user_query -< () - restrict -< tenant_id .== (constant t_tenantid) - returnA -< row + +import Prelude hiding (id) + +updateUser :: User -> AppM User +updateUser user = updateAuditableRow userTable user + +activateUser :: User -> AppM User +activateUser user = setUserStatus user UserStatusActive + +deactivateUser :: User -> AppM User +deactivateUser user = setUserStatus user UserStatusInActive + +setUserStatus :: User -> UserStatus -> AppM User +setUserStatus user newStatus = updateUser $ user & status .~ newStatus + +removeUser :: User -> AppM GHC.Int.Int64 +removeUser user = removeAuditableRow userTable user + +readUsers :: AppM [User] +readUsers = wrapAuditable $ readRow userQuery + +readUsersForTenant :: TenantId -> AppM [User] +readUsersForTenant tenantId = wrapAuditable $ readRow $ userQueryByTenantid tenantId + +readUserById :: UserId -> AppM (Maybe User) +readUserById id' = do + wrapAuditable $ listToMaybe <$> (readRow $ userQueryById id') + +addRoleToUser :: UserId -> RoleId -> AppM [(UserId, RoleId)] +addRoleToUser userId roleId = + createDbRows userRolePivotTable [(constant (userId, roleId))] + +removeRoleFromUser :: UserId -> RoleId -> AppM GHC.Int.Int64 +removeRoleFromUser tUserId tRoleId = removeRawDbRows userRolePivotTable + (\(userId, roleId) -> (userId .== constant tUserId) .&& (roleId .== constant tRoleId)) + +userQuery :: Query UserTableR +userQuery = queryTable userTable + +userQueryById :: UserId -> Query UserTableR +userQueryById tId = proc () -> do + user <- userQuery -< () + restrict -< (user ^. id) .== (constant tId) + returnA -< user + +userQueryByTenantid :: TenantId -> Query UserTableR +userQueryByTenantid tTenantid = proc () -> do + user <- userQuery -< () + restrict -< (user ^. tenantid) .== (constant tTenantid) + returnA -< user diff --git a/SpockOpaleye/src/UserServices.hs b/SpockOpaleye/src/UserServices.hs new file mode 100644 index 0000000..82f0d60 --- /dev/null +++ b/SpockOpaleye/src/UserServices.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module UserServices where + +import AppCore +import Control.Lens +import Email +import qualified Data.Text as T +import Data.Monoid +import Control.Monad.IO.Class +import Validations +import TenantApi + +doCreateTenant :: TenantIncoming -> AppM (Either T.Text Tenant) +doCreateTenant incomingTenant = do + result <- validateIncomingTenant incomingTenant + case result of + Valid -> do + newTenant <- createTenant incomingTenant + f <- return (head []) + liftIO $ putStrLn f + liftIO $ sendTenantActivationMail newTenant + return $ Right newTenant + Invalid err -> return $ Left $ T.concat ["Validation fail with ", T.pack err] diff --git a/SpockOpaleye/src/Validations.hs b/SpockOpaleye/src/Validations.hs index 991ddf3..3640d68 100644 --- a/SpockOpaleye/src/Validations.hs +++ b/SpockOpaleye/src/Validations.hs @@ -1,27 +1,39 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + module Validations where -import Data.Maybe +import AppCore +import Control.Lens import qualified Data.Text as T -import Database.PostgreSQL.Simple -import DataTypes import TenantApi -validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult -validateIncomingTenant conn tenant@Tenant {tenant_name = name - ,tenant_firstname = fn - ,tenant_lastname = ln - ,tenant_email = em - ,tenant_phone = phone - ,tenant_backofficedomain = bo_domain} = do - unique_bod <- check_for_unique_bo_domain - return $ - if and [unique_bod, validate_name, validate_contact] - then Valid - else Invalid +data ValidationResult = Valid | Invalid String + deriving (Eq, Show) + +validateIncomingTenant :: TenantIncoming -> AppM ValidationResult +validateIncomingTenant tenant = do + unique_bod <- check_for_unique_bo_domain (tenant ^. backofficedomain) + let result = do + unique_bod + if validate_contact then Right () + else (Left "Firstname, Lastname, Email, Phone cannot be blank") + if validate_name then Right () + else (Left "Name cannot be blank") + return $ case result of + Right () -> Valid + Left err -> Invalid err where - validate_contact = and $ (>= 0) . T.length <$> [fn, ln, em, phone] - validate_name = (T.length name) >= 3 - check_for_unique_bo_domain = - isNothing <$> read_tenant_by_backofficedomain conn bo_domain + validate_contact = and $ (>= 0) . T.length <$> [tenant ^. firstname, tenant ^. lastname, tenant ^. email, tenant ^. phone] + validate_name = (T.length $ tenant ^. name) >= 3 + check_for_unique_bo_domain :: T.Text -> AppM (Either String ()) + check_for_unique_bo_domain domain = v <$> readTenantByBackofficedomain domain + where + v :: Maybe Tenant -> Either String () + v (Just _) = Left "Duplicate backoffice domain" + v _ = Right () diff --git a/SpockOpaleye/stack.yaml b/SpockOpaleye/stack.yaml index bf15b27..f41c090 100644 --- a/SpockOpaleye/stack.yaml +++ b/SpockOpaleye/stack.yaml @@ -37,6 +37,8 @@ resolver: lts-7.5 # will not be run. This is useful for tweaking upstream packages. packages: - '.' +- hs-airbrake +- appcore - location: git: https://github.com/agrafix/Spock.git commit: 77333a2de5dea0dc8eba9432ab16864e93e5d70e @@ -46,7 +48,8 @@ packages: - reroute # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [] +extra-deps: +- mime-mail-0.4.12 # Override default flag values for local packages and extra-deps flags: {} @@ -67,7 +70,9 @@ extra-package-dbs: [] # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +extra-lib-dirs: [] # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor +ghc-options: + SpockOpaleye: -ddump-splices