HDBC DomainAPI

.gitignore

@@ -17,3 +17,4 @@ cabal.sandbox.config
 *.eventlog
 .stack-work/
 cabal.project.local
+*.swp

ServantHDBC/.gitignore

@@ -0,0 +1,2 @@
+# Stack uses this directory as scratch space.
+/.stack-work/

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.

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
+

ServantHDBC/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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)
+
+

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

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
+--    -}

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