Skip to content

Instantly share code, notes, and snippets.

@codedmart

codedmart/Main.hs

Created July 17, 2015 13:19
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save codedmart/0a39e54250f6f03d1c37 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save codedmart/0a39e54250f6f03d1c37 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
Main.hs
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
import Servant hiding (Get, Post, Put, Delete, ReqBody)
import qualified Servant as S
import Data.Monoid ((<>))
import Data.Either.Unwrap (fromRight)
import Data.Text (Text)
import System.Console.CmdArgs
import Data.Text.Lazy (pack)
import Network.Wai.Handler.Warp (run)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Morph (hoist)
{-import Control.Monad.Trans.Except-}
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader
import Data.Functor.Identity
import Network.Wai
import Network.Wai.Middleware.Cors
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL
import qualified Data.ByteString.Lazy.Char8 as BL
import Network.EngineIO.Wai
import qualified Network.SocketIO as SocketIO
import qualified Control.Concurrent.STM as STM
import Lib.Chat
import Lib.Config
import Lib.RethinkDB
import Model.Types.User (SecureUser)
import Model.Types.UserSignup (UserSignup)
import Model.Types.UserEdit (UserEdit)
import qualified Model.User as User
type Get a = S.Get '[JSON] a
type Post a = S.Post '[JSON] a
type Put a = S.Put '[JSON] a
type Delete a = S.Delete '[JSON] a
type ReqBody a = S.ReqBody '[JSON] a
type UsersAPI =
Get [SecureUser]
:<|> ReqBody UserSignup :> Post SecureUser
:<|> Capture "id" Text :> ReqBody UserEdit :> Put SecureUser
:<|> Capture "id" Text :> Delete ()
usersServer :: ServerT UsersAPI AppIO
usersServer =
getUsers
:<|> postUser
:<|> putUser
:<|> deleteUser
where
getUsers :: AppIO [SecureUser]
getUsers = User.list
postUser :: UserSignup -> AppIO SecureUser
postUser = User.create
putUser :: Text -> UserEdit -> AppIO SecureUser
putUser = User.update
deleteUser :: Text -> AppIO ()
deleteUser = User.delete
type API =
Get ApiInfo
:<|> "users" :> UsersAPI
serverT :: ServerT API AppIO
serverT = getApiInfo
:<|> usersServer
where
getApiInfo :: AppIO ApiInfo
getApiInfo = apiInfo
appIOToEither' :: AppConfig -> AppIO a -> EitherT ServantErr IO a
appIOToEither' t r = runReaderT (hoist (EitherT . runEitherT) r) t
appIOToEither :: AppConfig -> AppIO :~> EitherT ServantErr IO
appIOToEither t = Nat $ appIOToEither' t
api :: Proxy API
api = Proxy
server :: AppConfig -> Server API
server t = enter (appIOToEither t) serverT
type RawAPI =
"socket.io" :> Raw
rawAPI :: Proxy RawAPI
rawAPI = Proxy
rawServer :: AppConfig -> WaiMonad () -> Server RawAPI
rawServer h = socketIO
where
{-socketIOHandler ::-}
socketIO h req respond = toWaiApplication h req respond
corsResourcePolicy :: CorsResourcePolicy
corsResourcePolicy = CorsResourcePolicy
{ corsOrigins = Just (["chrome-extension://aicmkgpgakddgnaphhhpliifpcfhicfo", "http://getmetal.org"], True)
, corsMethods = ["GET", "HEAD", "OPTIONS", "POST", "PUT", "DELETE"]
, corsRequestHeaders = simpleResponseHeaders
, corsExposedHeaders = Nothing
, corsMaxAge = Nothing
, corsVaryOrigin = False
, corsRequireOrigin = False
, corsIgnoreFailures = False
}
stack :: Application -> Application
stack app = cors' $ app
where
cors' = cors (const $ Just corsResourcePolicy)
app :: AppConfig -> WaiMonad () -> Application
app t h = serve api $ server t :<|> rawAPI $ rawServer t h
main :: IO ()
main = do
-- setup environment
args <- cmdArgs $ AppOptions "development"
-- socketio
state <- ServerState <$> STM.newTVarIO 0
handler <- SocketIO.initialize waiAPI $ eioServer state
-- Config
p <- createRethinkPool "localhost"
cfg <- parseConfig (env args) (pack ".api")
let dbh = dbHost cfg
-- DB
p <- createRethinkPool dbh
let tn = AppConfig p cfg
-- RethinkDB setup
setupDB dbh
putStrLn $ "Running on " <> show 3001
run 3001 $ stack $ app tn handler
@alpmestan
Copy link
Copy Markdown

alpmestan commented Jul 17, 2015 

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}

import Servant hiding (Get, Post, Put, Delete, ReqBody)
import qualified Servant as S
import Data.Monoid ((<>))
import Data.Either.Unwrap (fromRight)
import Data.Text (Text)
import System.Console.CmdArgs
import Data.Text.Lazy (pack)
import Network.Wai.Handler.Warp (run)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Morph (hoist)
{-import Control.Monad.Trans.Except-}
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader
import Data.Functor.Identity
import Network.Wai
import Network.Wai.Middleware.Cors
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL
import qualified Data.ByteString.Lazy.Char8 as BL
import Network.EngineIO.Wai
import qualified Network.SocketIO as SocketIO
import qualified Control.Concurrent.STM as STM

import Lib.Chat
import Lib.Config
import Lib.RethinkDB
import Model.Types.User (SecureUser)
import Model.Types.UserSignup (UserSignup)
import Model.Types.UserEdit (UserEdit)
import qualified Model.User as User

type Get a = S.Get '[JSON] a
type Post a = S.Post '[JSON] a
type Put a = S.Put '[JSON] a
type Delete a = S.Delete '[JSON] a
type ReqBody a = S.ReqBody '[JSON] a

type UsersAPI =
    Get [SecureUser]
    :<|> ReqBody UserSignup :> Post SecureUser
    :<|> Capture "id" Text :> ReqBody UserEdit :> Put SecureUser
    :<|> Capture "id" Text :> Delete ()

usersServer :: ServerT UsersAPI AppIO
usersServer =
    getUsers
    :<|> postUser
    :<|> putUser
    :<|> deleteUser
    where
        getUsers :: AppIO [SecureUser]
        getUsers = User.list

        postUser :: UserSignup -> AppIO SecureUser
        postUser = User.create

        putUser :: Text -> UserEdit -> AppIO SecureUser
        putUser = User.update

        deleteUser :: Text -> AppIO ()
        deleteUser = User.delete

type API =
    Get ApiInfo
    :<|> "users" :> UsersAPI

serverT :: ServerT API AppIO
serverT = getApiInfo
    :<|> usersServer
    where
        getApiInfo :: AppIO ApiInfo
        getApiInfo = apiInfo

appIOToEither' :: AppConfig -> AppIO a -> EitherT ServantErr IO a
appIOToEither' t r = runReaderT (hoist (EitherT . runEitherT) r) t

appIOToEither :: AppConfig -> AppIO :~> EitherT ServantErr IO
appIOToEither t = Nat $ appIOToEither' t

server :: AppConfig -> Server API
server t = enter (appIOToEither t) serverT

type RawAPI = "socket.io" :> Raw

rawServer :: WaiMonad () -> Server RawAPI
rawServer h req respond = toWaiApplication h req respond
-- i.e rawServer = toWaiApplication

corsResourcePolicy :: CorsResourcePolicy
corsResourcePolicy = CorsResourcePolicy
    { corsOrigins = Just (["chrome-extension://aicmkgpgakddgnaphhhpliifpcfhicfo", "http://getmetal.org"], True)
    , corsMethods = ["GET", "HEAD", "OPTIONS", "POST", "PUT", "DELETE"]
    , corsRequestHeaders = simpleResponseHeaders
    , corsExposedHeaders = Nothing
    , corsMaxAge = Nothing
    , corsVaryOrigin = False
    , corsRequireOrigin = False
    , corsIgnoreFailures = False
    }

stack :: Application -> Application
stack app = cors' $ app
    where
        cors' = cors (const $ Just corsResourcePolicy)

entireApi :: Proxy (API :<|> RawAPI)
entireApi = Proxy

app :: AppConfig -> WaiMonad () -> Application
app t h = serve entireApi $ server t :<|> rawServer h

main :: IO ()
main = do
    -- setup environment
    args <- cmdArgs $ AppOptions "development"

    -- socketio
    state <- ServerState <$> STM.newTVarIO 0
    handler <- SocketIO.initialize waiAPI $ eioServer state

    -- Config
    p <- createRethinkPool "localhost"
    cfg <- parseConfig (env args) (pack ".api")
    let dbh = dbHost cfg

    -- DB
    p <- createRethinkPool dbh
    let tn = AppConfig p cfg

    -- RethinkDB setup
    setupDB dbh

    putStrLn $ "Running on " <> show 3001
    run 3001 $ stack $ app tn handler

This should work I think.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment