Main.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

module Main where

import Grocery.Database
import Grocery.Types

import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans (liftIO)
import Control.Monad (void)
import Data.IORef
import Data.Proxy
import Data.Time
import Data.Aeson
import Data.Monoid

import Web.Spock.Simple
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Static
import Network.Socket

import qualified Database.Persist as DB
import qualified Database.Persist.Sqlite as DB

import GHC.Generics

getPool :: IO DB.ConnectionPool
getPool = do
  let s = "ghci.db"
  let n = 1
  runStdoutLoggingT (DB.createSqlitePool s n)

runDB :: DB.ConnectionPool -> DB.SqlPersistT IO a -> IO a
runDB pool query = liftIO $ DB.runSqlPool query pool

main = do
  pool <- getPool
  runDB pool (DB.runMigration migrateAll)

  mainApp <- spockAsApp $ spock sessionConfig (PCPool pool) appState routes
  run 7000 $ applyMiddleware $ mainApp

  where
    sessionConfig :: SessionCfg Int
    sessionConfig = SessionCfg {
                        sc_cookieName = "grocery"
                      , sc_sessionTTL = 86000 -- check if seconds
                      , sc_sessionIdEntropy = 10
                      , sc_emptySession = 0
                      , sc_persistCfg = Nothing
                      }

    -- No App State we care about
    appState = ()

routes :: SpockM conn sess () ()
routes = do
  get "/" $ text "Hello World"
  post "/login" $ do
    user <- jsonBody
    liftIO $ print (user :: Maybe User)
    text "Got it."

applyMiddleware :: Application -> Application
applyMiddleware = logStdoutDev . (gzip def) . staticServing
  where
    staticServing = staticPolicy (noDots <> addBase "static")