diff --git a/.gitignore b/.gitignore index a4ee41a..5606f40 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,4 @@ cabal.sandbox.config *.eventlog .stack-work/ cabal.project.local +*.swp diff --git a/ServantHDBC/.gitignore b/ServantHDBC/.gitignore new file mode 100644 index 0000000..7bfc5c0 --- /dev/null +++ b/ServantHDBC/.gitignore @@ -0,0 +1,2 @@ +# Stack uses this directory as scratch space. +/.stack-work/ diff --git a/ServantHDBC/LICENSE b/ServantHDBC/LICENSE new file mode 100644 index 0000000..fc03544 --- /dev/null +++ b/ServantHDBC/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/ServantHDBC/ServantHDBC.cabal b/ServantHDBC/ServantHDBC.cabal new file mode 100644 index 0000000..272b1f9 --- /dev/null +++ b/ServantHDBC/ServantHDBC.cabal @@ -0,0 +1,45 @@ +name: ServantHDBC +version: 0.1.0.0 +synopsis: Simple project template from stack +description: Please see README.md +homepage: https://github.com/githubuser/ServantHDBC#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2016 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable ServantHDBC + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + build-depends: base == 4.8.2.0, + bytestring == 0.10.6.0, + convertible == 1.1.1.0, + aeson == 0.11.2.1, + either == 4.4.1.1, + HDBC == 2.4.0.1, + HDBC-postgresql >= 2.2, + http-api-data == 0.2.4, + mtl == 2.2.1, + servant-server == 0.7.1, + split == 0.2.3.1, + text == 1.2.2.1, + time == 1.5.0.1, + transformers == 0.4.2.0, + utf8-string == 1.0.1.1, + wai == 3.2.1.1, + warp == 3.2.8 + other-modules: Config, + DomainApi, + RestApi, + RestApi.Authentication, + RestApi.Photo, + RestApi.Product, + RestApi.Tenant, + Types, + Util + diff --git a/ServantHDBC/Setup.hs b/ServantHDBC/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/ServantHDBC/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ServantHDBC/src/Config.hs b/ServantHDBC/src/Config.hs new file mode 100644 index 0000000..ef5e11f --- /dev/null +++ b/ServantHDBC/src/Config.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Config where + +import Control.Monad.Trans.Except +import Control.Monad.Reader +import Database.HDBC.PostgreSQL +import Servant + + +type AppM = ReaderT Config (ExceptT ServantErr IO) + +data Config = Config + { getConnection :: Connection + , getEnv :: Environment + } + +data Environment + = Development + | Test + | Production + deriving (Eq, Show, Read) + + diff --git a/ServantHDBC/src/DomainApi.hs b/ServantHDBC/src/DomainApi.hs new file mode 100644 index 0000000..d907f45 --- /dev/null +++ b/ServantHDBC/src/DomainApi.hs @@ -0,0 +1,119 @@ +module DomainApi where + +import Data.List +import Data.Maybe +import Data.Time.Clock +import Database.HDBC +import Database.HDBC.PostgreSQL +import Types +import Util + +getTenant :: Connection -> Int -> IO (Maybe Tenant) +getTenant conn id = do + select <- prepare conn "select id, created_at, updated_at, name, first_name, last_name, email, phone, status, owner_id, backoffice_domain from tenants where id = ? " + execute select [toSql id] + row <- fetchRow select + let t = fmap (mkData11 Tenant) row + return $ case t of + Just (Just t) -> Just t + _ -> Nothing + +createTenant :: Connection -> Tenant -> IO (Maybe Int) +createTenant conn (Tenant _ created updated name first last email phone status owner backoffice) = do + putStrLn $ (show status) ++ " " ++ (show (toSql status)) + now <- getCurrentTime + ins <- prepare conn "insert into tenants (created_at, updated_at, name, first_name, last_name, email, phone, owner_id, backoffice_domain, status) values (?, ?, ?, ?, ?, ?, ?, ?, ?, 'new') returning id" + execute ins [toSql now, toSql now, toSql name, toSql first, toSql last, toSql email, toSql phone, toSql owner, toSql backoffice] + result <- fetchRow ins + commit conn + putStrLn "done" + return $ case result of + Just (x:[]) -> Just (fromSql x) + _ -> Nothing + + +activateTenant :: Connection -> Tenant -> User -> IO () +activateTenant conn (Tenant id _ _ _ _ _ _ _ _ _ _) (User owner _ _ _ _ _ _ _ _ ) = do + now <- getCurrentTime + upd <- prepare conn "update tenants set status='active',updated_at=?,owner_id=? where id = ?" + execute upd [toSql now, toSql owner, toSql id] + commit conn + return () + + +createUser :: Connection -> User -> IO (Maybe Int) +createUser conn (User _ _ _ tenant_id username password first last _) = do + now <- getCurrentTime + ins <- prepare conn "insert into users (created_at, updated_at, tenant_id, username, password, first_name, last_name, status) values (?, ?, ?, ?, ?, ?, ?, 'inactive') returning id;" + execute ins [toSql now, toSql now, toSql tenant_id, toSql username, toSql password, toSql first, toSql last ] + result <- fetchRow ins + commit conn + return $ case result of + Just (x:[]) -> Just (fromSql x) + _ -> Nothing + +getUser :: Connection -> Int -> IO (Maybe User) +getUser conn id = do + select <- prepare conn "select id, created_at, updated_at, tenant_id, username, password, first_name, last_name, status from users where id = ? " + execute select [toSql id] + row <- fetchRow select + let u = fmap (mkData9 User) row + return $ case u of + Just (Just u) -> Just u + _ -> Nothing + + +setUserStatus :: Connection -> Int -> String -> IO () +setUserStatus conn id status = do + now <- getCurrentTime + upd <- prepare conn "update users set status=? ,updated_at=? where id = ?" + execute upd [toSql status, toSql now, toSql id] + commit conn + return () + +activateUser:: Connection -> User -> IO () +activateUser conn user = setUserStatus conn (_uid user) "active" + +deactivateUser:: Connection -> User -> IO () +deactivateUser conn user = setUserStatus conn (_uid user) "inactive" + +createRole :: Connection -> Role -> IO (Maybe Int) +createRole conn (Role _ tenant_id name permissions _ _) = do + now <- getCurrentTime + ins <- prepare conn "insert into roles (tenant_id, name, permissions, created_at, updated_at) values (?, ?, ?, ?, ?) returning id;" + execute ins [toSql tenant_id, toSql name, toSql permissions, toSql now, toSql now ] + result <- fetchRow ins + putStrLn $ show result + commit conn + return $ case result of + Just (x:[]) -> Just (fromSql x) + _ -> Nothing + +getRole :: Connection -> Int -> IO (Maybe Role) +getRole conn id = do + select <- prepare conn "select id, tenant_id, name, permissions, created_at , updated_at from roles where id = ? " + execute select [toSql id] + row <- fetchRow select + let role = fmap (mkData6 Role) row + return $ case role of + Just (Just role) -> Just role + _ -> Nothing + +addRole :: Connection -> User -> Role -> IO () +addRole conn user role = do + ins <- prepare conn "insert into users_roles (user_id, role_id) values (?, ?);" + execute ins [toSql $ _uid user, toSql $ _rid role] + commit conn + +removeRole :: Connection -> User -> Role -> IO () +removeRole conn user role = do + del <- prepare conn "delete from users_roles where user_id = ? and role_id = ?;" + execute del [toSql $ _uid user, toSql $ _rid role] + commit conn + +getPermissions :: Connection -> User -> IO [Permission] +getPermissions conn user = do + select <- prepare conn "select permissions from roles inner join users_roles on roles.id = users_roles.role_id where users_roles.user_id = ?" + execute select [toSql $ _uid user] + row <- fetchAllRows select + return $ nub $ sort $ concatMap permissionsFromSql $ map fromSql $ concat row diff --git a/ServantHDBC/src/Main.hs b/ServantHDBC/src/Main.hs new file mode 100644 index 0000000..d0be978 --- /dev/null +++ b/ServantHDBC/src/Main.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Config +import Control.Monad.Trans.Except +import Control.Monad.Reader +import Data.Maybe +import Data.Time.Clock +import DomainApi +import Network.Wai +import Network.Wai.Handler.Warp +import RestApi +import Servant +import Types + +import qualified Database.HDBC as DB +import Database.HDBC.PostgreSQL + + +readerToHandler :: Config -> AppM :~> ExceptT ServantErr IO +readerToHandler cfg = Nat $ \x -> runReaderT x cfg + +cartServer :: Config -> Server ShoppingCartAPI +cartServer cfg = enter (readerToHandler cfg) handlers + +shoppingCart ::Proxy ShoppingCartAPI +shoppingCart = Proxy + +application :: Config -> Application +application cfg = serve shoppingCart (cartServer cfg) + +main :: IO () +main = do + putStrLn "start" + now <- getCurrentTime + conn <- connectPostgreSQL "host=localhost dbname=cart user=cart password=cart" + let t = Tenant 0 now now "asdf" "foo" "bar" "a@example.com" "phone" TenantInactive Nothing (show now) + tid <- createTenant conn t + tenant <- getTenant conn $ fromJust tid + + let u = User 0 now now (_tid $ fromJust tenant) ("user" ++ show now) "pass" "first" "last" "new" + uid <- createUser conn u + user <- getUser conn $ fromJust uid + putStrLn $ show user + deactivateUser conn $ fromJust user + user <- getUser conn $ fromJust uid + putStrLn $ show user + activateUser conn $ fromJust user + user <- getUser conn $ fromJust uid + putStrLn $ show user + + + activateTenant conn (fromJust tenant) (fromJust user) + putStrLn $ show tenant + tenant <- getTenant conn $ fromJust tid + putStrLn $ show tenant + + let r = Role 0 (fromJust tid) "reader" [ReadFoo, ReadBar] now now + rid <- createRole conn r + role <- getRole conn $ fromJust rid + putStrLn $ show role + + addRole conn (fromJust user) (fromJust role) + permissions <- getPermissions conn (fromJust user) + putStrLn $ show $ permissions + removeRole conn (fromJust user) (fromJust role) + permissions <- getPermissions conn (fromJust user) + putStrLn $ show $ permissions +{- + let cfg = Config conn Development + let app = application $ Config conn Development + run 8000 app +-- select <- DB.prepare conn "select * from tenants" +-- DB.execute select [] +-- results <- DB.fetchAllRows select +-- putStrLn $ show results +-- putStrLn "connected" +-- putStrLn "starting ServantHDBC" +-- run 8000 application +-- -} diff --git a/ServantHDBC/src/RestApi.hs b/ServantHDBC/src/RestApi.hs new file mode 100644 index 0000000..72363de --- /dev/null +++ b/ServantHDBC/src/RestApi.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module RestApi (ShoppingCartAPI, handlers) where + +import RestApi.Authentication +import RestApi.Photo +import RestApi.Product +import RestApi.Tenant +import Servant + +type ShoppingCartAPI = + TenantAPI +-- :<|> AuthAPI +-- :<|> ProductAPI +-- :<|> PhotoAPI + +--handlers :: ShoppingCartAPI +handlers = + tenantHandlers +-- :<|> authHandlers +-- :<|> productHandlers +-- :<|> photoHandlers + +--shoppingCart :: Proxy ShoppingCartAPI +--shoppingCart = Proxy diff --git a/ServantHDBC/src/RestApi/Authentication.hs b/ServantHDBC/src/RestApi/Authentication.hs new file mode 100644 index 0000000..5bbaea1 --- /dev/null +++ b/ServantHDBC/src/RestApi/Authentication.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module RestApi.Authentication (AuthAPI, authHandlers) where + +import Control.Monad.Trans.Except +import Data.Aeson +import GHC.Generics +import Servant + +data Auth = Auth String + deriving (Generic) + +instance FromJSON Auth + +type AuthAPI = "sessions" :> AuthAPI' + +type AuthAPI' = + "new" + :> ReqBody '[JSON] Auth + :> Post '[JSON] String + :<|> "refresh" + :> ReqBody '[JSON] Auth + :> Post '[JSON] String + :<|> "destroy" + :> ReqBody '[JSON] Auth + :> Post '[JSON] String + +authNew :: Auth -> ExceptT ServantErr IO String +authNew _ = return "should create a cookie" + +authRefresh :: Auth -> ExceptT ServantErr IO String +authRefresh _ = return "should refresh session timeout" + +authDestroy :: Auth -> ExceptT ServantErr IO String +authDestroy _ = return "should destroy the session" + +authHandlers = authNew :<|> authRefresh :<|> authDestroy + diff --git a/ServantHDBC/src/RestApi/Photo.hs b/ServantHDBC/src/RestApi/Photo.hs new file mode 100644 index 0000000..7941a5d --- /dev/null +++ b/ServantHDBC/src/RestApi/Photo.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module RestApi.Photo (PhotoAPI, photoHandlers) where + +import Control.Monad.Trans.Except +import Data.Aeson +import GHC.Generics +import Servant + +type PhotoAPI = "photos" :> PhotoAPI' + +type PhotoAPI' = + Capture "path_segment_1" String :> + Capture "path_segment_2" String :> + Capture "geometry_or_style" String :> + Capture "original_filename" String :> + Get '[JSON] String + +photoGet :: String -> + String -> + String -> + String -> + ExceptT ServantErr IO String +photoGet path1 path2 geometry filename = return "return a photo" + +photoHandlers = photoGet diff --git a/ServantHDBC/src/RestApi/Product.hs b/ServantHDBC/src/RestApi/Product.hs new file mode 100644 index 0000000..ec5cd2f --- /dev/null +++ b/ServantHDBC/src/RestApi/Product.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + + +module RestApi.Product (ProductAPI, productHandlers) where + +import Control.Monad.Trans.Except +import Data.Aeson +import Data.Text +import Data.Time.Clock +import GHC.Generics +import Servant +import Web.HttpApiData + + + +data Product = Product + { id :: String + , tenant_id :: String + , name :: String + , description :: String + , url_slug :: String + , tags :: String + , currency :: String + , advertised_price :: Int + , comparison_price :: Int + , cost_price :: Int + , product_type :: String + , is_published :: Bool + , properties :: String + } deriving (Generic) + +instance FromJSON Product + +data Field = Field String + +instance FromHttpApiData Field where + parseUrlPiece x = fmap Field (parseUrlPiece x :: Either Text String) + + +data ProductId = ProductId Int + +instance FromHttpApiData ProductId where + parseUrlPiece x = fmap ProductId (parseUrlPiece x :: Either Text Int) + +data Sku = Sku String + +instance FromHttpApiData Sku where + parseUrlPiece x = fmap Sku (parseUrlPiece x :: Either Text String) + +data ProductType = ProductType String + +instance FromHttpApiData ProductType where + parseUrlPiece x = fmap ProductType (parseUrlPiece x :: Either Text String) + +data ProductOrdering = ProductOrdering Int + +instance FromHttpApiData ProductOrdering where + parseUrlPiece x = fmap ProductOrdering (parseUrlPiece x :: Either Text Int) + +type ProductAPI = "products" :> ProductAPI' + +type ProductAPI' = + Capture "product_id" Int :> + QueryParams "fields" Field :> + QueryParam "photo_sizes" String :> + QueryParam "varants.photo_sizes" String :> + Get '[JSON] String + :<|> QueryParams "ids" ProductId :> + QueryParam "q" String :> + QueryParam "title" String :> + QueryParam "sku" Sku :> + QueryParam "type" ProductType :> + QueryParam "tags" String :> + QueryParam "created_at_min" UTCTime :> + QueryParam "created_at_max" UTCTime :> + QueryParam "updated_at_min" UTCTime :> + QueryParam "updated_at_max" UTCTime :> + QueryParam "limit" Int :> + QueryParam "offset" Int :> + QueryParam "orderby" ProductOrdering :> + QueryParams "fields" Field :> + Get '[JSON] String + :<|> "new" :> + ReqBody '[JSON] Product :> + Post '[JSON] String + +productGet :: Int -> + [Field] -> + Maybe String -> + Maybe String -> + ExceptT ServantErr IO String +productGet id fields photo_sizes variants = + return $ "get a product from id " ++ show id + +productList + :: [ProductId] + -> Maybe String + -> Maybe String + -> Maybe Sku + -> Maybe ProductType + -> Maybe String + -> Maybe UTCTime + -> Maybe UTCTime + -> Maybe UTCTime + -> Maybe UTCTime + -> Maybe Int + -> Maybe Int + -> Maybe ProductOrdering + -> [Field] + -> ExceptT ServantErr IO String + +productList ids q title sku item_type tags created_at_mix created_at_max + updated_at_min updated_at_max limit offset orderby fields + = return "list products by query params" + +productNew :: Product -> ExceptT ServantErr IO String +productNew product = return "create a new product" + +productHandlers = productGet :<|> productList :<|> productNew + diff --git a/ServantHDBC/src/RestApi/Tenant.hs b/ServantHDBC/src/RestApi/Tenant.hs new file mode 100644 index 0000000..b80c781 --- /dev/null +++ b/ServantHDBC/src/RestApi/Tenant.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module RestApi.Tenant (TenantAPI, tenantHandlers) where + +import Config +import Control.Monad.Trans.Except +import Control.Monad.Reader +import Data.Aeson +import Data.Time.Clock +import DomainApi +import GHC.Generics +import Servant +import Types + + +type TenantAPI = "tenants" :> TenantAPI' + +type TenantAPI' = + "new" + :> ReqBody '[JSON] Tenant + :> Post '[JSON] String + :<|> Capture "x" Int + :> Get '[JSON] String + :<|> Capture "x" Int :> "activate" + :> ReqBody '[JSON] Tenant + :> Post '[JSON] String + +tenantNew :: Tenant -> AppM String +tenantNew t = return "new tenant" + + +tenantGet :: Int -> AppM String +tenantGet x = do + conn <- asks getConnection + r <- lift $ lift $ getTenant conn x + return "" + + +tenantActivate :: Int -> Tenant -> AppM String +tenantActivate x t = return $ "activating " ++ show x ++ " " + +tenantHandlers = tenantNew :<|> tenantGet :<|> tenantActivate diff --git a/ServantHDBC/src/Types.hs b/ServantHDBC/src/Types.hs new file mode 100644 index 0000000..4e623ca --- /dev/null +++ b/ServantHDBC/src/Types.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Types where + +import Data.Aeson +import Data.ByteString.UTF8 +import Data.Convertible.Base +import Data.List +import Data.List.Split +import Data.Time +import Data.Time.Clock +import GHC.Generics +import Database.HDBC.SqlValue + +data Tenant = Tenant + { _tid:: Int + , _tcreated_at :: UTCTime + , _tupdated_at :: UTCTime + , _tname :: String + , _tfirst_name :: String + , _tlast_name :: String + , _temail :: String + , _tphone :: String + , _tstatus :: TenantStatus + , _towner_id :: Maybe Int + , _tbackoffice_domain :: String + } + deriving (Generic, Show) +instance FromJSON Tenant + + +data TenantStatus = TenantNew | TenantInactive | TenantActive + deriving (Generic, Show) + +instance FromJSON TenantStatus + +instance Convertible SqlValue TenantStatus where + safeConvert (SqlString a) = case a of + "new" -> Right TenantNew + "active" -> Right TenantActive + "inactive" -> Right TenantInactive + _ -> Left $ ConvertError (show a) "SqlValue" "TenantStatus" "Unrecognized value" + safeConvert (SqlByteString a) = safeConvert $ SqlString $ toString a + safeConvert a = Left $ ConvertError (show a) "SqlValue" "TenantStatus" "No conversion available" + +instance Convertible TenantStatus SqlValue where + safeConvert TenantNew = Right $ SqlString "new" + safeConvert TenantInactive = Right $ SqlString "inactive" + safeConvert TenantActive = Right $ SqlString "active" + +data User = User + { _uid :: Int + , _ucreated_at :: UTCTime + , _uupdated_at :: UTCTime + , _utenant_id :: Int + , _uusername :: String + , _upassword :: String + , _ufirst_name :: String + , _ulast_name :: String + , _status :: String + } + deriving (Generic, Show) + +data UserStatus = UserActive | UserInactive | UserBlocked + deriving (Generic, Show) +instance FromJSON UserStatus + +instance Convertible SqlValue UserStatus where + safeConvert (SqlString a) = case a of + "active" -> Right UserActive + "inactive" -> Right UserInactive + "blocked" -> Right UserBlocked + _ -> Left $ ConvertError (show a) "SqlValue" "UserStatus" "Unrecognized value" + safeConvert (SqlByteString a) = safeConvert $ SqlString $ toString a + safeConvert a = Left $ ConvertError (show a) "SqlValue" "UserStatus" "No conversion available" + +instance Convertible UserStatus SqlValue where + safeConvert UserActive = Right $ SqlString "active" + safeConvert UserInactive = Right $ SqlString "inactive" + safeConvert UserBlocked = Right $ SqlString "blocked" + + +data Role = Role + { _rid :: Int + , _rtid :: Int + , _rname :: String + , _rpermissions :: [Permission] + , _created_at :: UTCTime + , _updated_at :: UTCTime + } + deriving (Generic, Show) + +data Permission = ReadFoo | WriteFoo | ReadBar | WriteBar + deriving (Eq, Ord, Generic, Read, Show) + +instance Convertible SqlValue Permission where + safeConvert (SqlString a) = case a of + "ReadFoo" -> Right ReadFoo + "WriteFoo" -> Right WriteFoo + "ReadBar" -> Right ReadBar + "WriteBar" -> Right WriteBar + _ -> Left $ ConvertError (show a) "SqlValue" "Permission" "Unrecognized value" + safeConvert (SqlByteString a) = safeConvert $ SqlString $ toString a + safeConvert a = Left $ ConvertError (show a) "SqlValue" "Permission" "No conversion available" + +permissionsToSql :: [Permission] -> SqlValue +permissionsToSql xs = toSql $ "{" ++ (intercalate "," $ map show xs) ++ "}" + +permissionsFromSql :: String -> [Permission] +permissionsFromSql str = map read $splitOn "," $ init $ tail str + +instance Convertible SqlValue [Permission] where + safeConvert (SqlString a) = Right $ permissionsFromSql a + safeConvert (SqlByteString a) = safeConvert $ SqlString $ toString a + safeConvert a = Left $ ConvertError (show a) "SqlValue" "[Permission]" "No conversion available" + +instance Convertible [Permission] SqlValue where + safeConvert a = Right $ permissionsToSql a diff --git a/ServantHDBC/src/Util.hs b/ServantHDBC/src/Util.hs new file mode 100644 index 0000000..4ad442b --- /dev/null +++ b/ServantHDBC/src/Util.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Util where + +import Database.HDBC + +mkData1 f (x1:[]) = Just $ f (fromSql x1) +mkData1 _ _ = Nothing +mkData2 f (x1:x2:[]) = Just $ f (fromSql x1) (fromSql x2) +mkData2 _ _ = Nothing +mkData6 f (x1:x2:x3:x4:x5:x6:[]) = Just $ f (fromSql x1) (fromSql x2) (fromSql x3) (fromSql x4) (fromSql x5) (fromSql x6) +mkData9 f (x1:x2:x3:x4:x5:x6:x7:x8:x9:[]) = Just $ f (fromSql x1) (fromSql x2) (fromSql x3) (fromSql x4) (fromSql x5) (fromSql x6) (fromSql x7) (fromSql x8) (fromSql x9) +mkData9 _ _ = Nothing +mkData11 f (x1:x2:x3:x4:x5:x6:x7:x8:x9:x10:x11:[]) = Just $ f (fromSql x1) (fromSql x2) (fromSql x3) (fromSql x4) (fromSql x5) (fromSql x6) (fromSql x7) (fromSql x8) (fromSql x9) (fromSql x10) (fromSql x11) +mkData11 _ _ = Nothing + + + + diff --git a/ServantHDBC/stack.yaml b/ServantHDBC/stack.yaml new file mode 100644 index 0000000..6752796 --- /dev/null +++ b/ServantHDBC/stack.yaml @@ -0,0 +1,67 @@ +# 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-6.22 + +# 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.1" +# +# 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 diff --git a/json-api-spec.apib b/json-api-spec.apib index 5a41b7c..b31aa90 100644 --- a/json-api-spec.apib +++ b/json-api-spec.apib @@ -214,7 +214,6 @@ Requires only the **cookies**. Do we need to do anything with the POST body? + created_at_max (iso8601) - filter product created before this timestamp (specified in iso8601 format) + updated_at_min (iso8601) - filter product updated on/after this timestamp (specified in iso8601 format) + updated_at_max (iso8601) - filter product updated before this timestamp (specified in iso8601 format) - + limit (iso8601) - filter product updated before this timestamp (specified in iso8601 format) + limit (number) - number of results to show. Should be less than 50. + offset (number) - starting position in the result list (maps to limit/offset in SQL) + orderby (string) - can be any valid field accepted by the `fields` parameter, concatenated by `.asc` or `.desc`, eg. `created_at.asc`. Default is `updated.desc`