app.cabal

name:                App
version:             0.1.0.0
synopsis:            App backend JSON API server
license:             AllRightsReserved
license-file:        LICENSE
author:              Cidevant
maintainer:          cidevant@mail.ru
category:            Web
build-type:          Simple
cabal-version:       >= 1.20

executable App
  hs-source-dirs:        src
  main-is:               Main.hs
  other-modules:         Models
                       , ModelsJson
  -- other-extensions:
  build-depends:          base >= 4 && < 5
                        , scotty > 0.7
                        , aeson
                        , persistent
                        , persistent-postgresql
                        , persistent-template
                        , http-types
                        , text
                        , bytestring
                        , time
                        , wai-extra
                        , wai-middleware-static
                        , transformers
                        , blaze-html
                        , scientific >= 0.2.0.2
                        , yaml
                        , conduit
                        , aeson

                        -- hDevTools with cabal-sandbox env.
                        , cabal-cargs

                        -- Live reload
                        , fsnotify
                        , system-fileio
                        , system-filepath
                        , process
                        , mtl

  default-language:    Haskell2010
  ghc-options:         -Wall -threaded

Main.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import           Control.Monad.IO.Class               (liftIO)

import           Network.HTTP.Types
import           Network.Wai.Middleware.RequestLogger
import           Network.Wai.Middleware.Static
import           Web.Scotty

import qualified Database.Persist.Postgresql          as Db

import           Models
import           ModelsJson

main :: IO()
main = Db.withPostgresqlPool connStr 10 $ \pool -> do

  -- Migrate database
  runDB pool $ Db.runMigration migrateAll

  -- Start server
  scotty 5001 $ do

    middleware logStdoutDev

    -- * Static content middleware
    --middleware $ staticPolicy (noDots >-> addBase "public")

    get "/" $
      html $ "<h1>Backend API server (haskell Scotty)</h1>"

    -- * CRUD

    get "/api/users" $ do
      (users :: [Db.Entity User]) <-
        liftIO $ runDB pool $ Db.selectList [] []
      json users

    post "/api/users" $ do
      (user :: User) <- jsonData
      uid <- liftIO $ runDB pool $ Db.insert user
      json $ Db.Entity uid user

    get "/api/users/:id" $ do
      (uid :: Integer) <- param "id"

      let (key :: Db.Key User) = Db.Key (Db.PersistInt64 $ fromIntegral uid)
      (userDb :: Maybe User) <-
        liftIO $ runDB pool $ Db.get $ key

      case userDb of
        Just user  -> do setHeader "Access-Control-Allow-Origin" "*"
                         json $ Db.Entity key user
        Nothing -> status notFound404

    put "/api/users/:id" $ do
      (uid :: Integer) <- param "id"

      let (key :: Db.Key User) = Db.Key (Db.PersistInt64 $ fromIntegral uid)
      (userJson :: User) <- jsonData
      (userDb :: Maybe User) <-
        liftIO $ runDB pool $ Db.get $ key

      case userDb of
        Just _  -> do liftIO $ runDB pool $ Db.replace key $ userJson
                      json $ Db.Entity key userJson
        Nothing -> status notFound404

    delete "/api/users/:id" $ do
      (uid :: Integer) <- param "id"
      let key :: Db.Key User = Db.Key (Db.PersistInt64 $ fromIntegral uid)
      (user :: Maybe User) <-
        liftIO $ runDB pool $ Db.get $ key
      case user of
        Just _  -> do liftIO $ runDB pool $ Db.delete $ key
                      status noContent204
        Nothing -> status notFound404

    -- Error handlers
    notFound $ do
      status notFound404
      html $ "<h1>Not found</h1>"


connStr :: Db.ConnectionString
connStr =  "host=localhost dbname=road_free_development user=cidevant password='' port=5432"

runDB :: Db.ConnectionPool ->  Db.SqlPersistM a -> IO a
runDB = flip Db.runSqlPersistMPool

Models.hs

{-# LANGUAGE EmptyDataDecls    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

module Models where

import Control.Applicative
import Control.Monad

import Data.Aeson
import qualified Data.Text as T

import Database.Persist
import Database.Persist.TH

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
User sql=users
     name T.Text
     client_id Int
     deriving Show Eq
|]

ModelsJson.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-# OPTIONS_GHC -fwarn-unused-matches -fwarn-unused-binds -fwarn-unused-imports #-}

module ModelsJson where

import           Control.Applicative
import           Control.Monad
import           Data.Aeson
import           Database.Persist
import           Models

instance ToJSON (Entity User) where
  toJSON (Entity uid (c@User{..})) =
    object
    [ "id" .= uid
    , "name" .= userName
    , "client_id" .= userClient_id
    ]

instance FromJSON User where
    parseJSON (Object v) =
        User <$> v .: "name"
             <*> v .: "client_id"
    parseJSON _ = mzero