Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 111 lines (101 sloc) 4.033 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Data.Default (def)
import Data.String (fromString)
import Data.Aeson
import qualified Data.Text as Text
import qualified Data.Vault as Vault

import Data.Acid (AcidState, Update, Query, makeAcidic, openLocalState)
import Data.Acid.Advanced (query')
import Data.Acid.Local (createCheckpointAndClose)
import Data.IxSet ((@=), Proxy(..), getOne)

import Network.Wai
import Network.Wai.Parse (parseRequestBody, lbsBackEnd)
import Network.Wai.Session (withSession)
import Network.Wai.Session.Map (mapStore_)
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types (ok200, unauthorized401, status404)

import Control.Exception (bracket)
import Control.Concurrent.Chan (Chan, newChan, dupChan, writeChan)
import Control.Monad.Trans.Resource (ResourceT)
    
import TypeSynonyms
import Util
import Model
import Handlers

routes :: DB -> SessionStore -> Request -> RES
routes db session req = do
  let Just (sessionLookup, sessionInsert) = Vault.lookup session (vault req)
  user <- sessionLookup "user"
  case pathInfo req of
    ("app":rest) ->
      loggedInRoutes db user rest req
    ("auth":rest) ->
      authRoutes db sessionLookup sessionInsert rest req
    ["static", subDir, fileName] ->
      serveStatic subDir fileName
    [] ->
      resFile "text/html" "static/index.html"
    ["favicon.ico"] ->
      resPlaceholder
    _ -> res404

authRoutes :: DB -> LookupFN -> InsertFN -> [Text.Text] -> Request -> RES
authRoutes db sLookup sInsert path req = do
  withPostParams req ["name", "passphrase"] route
  where route [name, pass] =
          case path of
            ["login"] ->
              login db sInsert name pass
            ["register"] ->
              case pass of
                "" -> resError "At least pick a non-empty passphrase"
                _ -> register db sInsert name pass
            _ -> res404

loggedInRoutes :: DB -> Maybe String -> [Text.Text] -> Request -> RES
loggedInRoutes db maybeUserName path req = do
  (params, _) <- parseRequestBody lbsBackEnd req
  case maybeUserName of
    Just name -> do
      maybeAccount <- query' db $ AccountByName name
      case maybeAccount of
        Just user -> case path of
          ("item":rest) ->
            withParams params ["itemName"] route
            where route [itemName] = itemRoutes db user itemName rest params
          ["list"] ->
            listItems db user
          ["new"] ->
            withParams params ["itemName", "comment", "count"] new
            where new [name, comment, ct] = case reads ct :: [(Integer, String)] of
                    (count, _):_ -> newItem db user name comment count
                    _ -> resError "Count needs to be readable as an Integer"
          ["change-passphrase"] ->
            withParams params ["newPassphrase"] change
            where change [newPass] = changePassphrase db user newPass
          _ -> res404
        Nothing -> resError "Invalid user"
    Nothing -> resError "Not Logged In"

itemRoutes :: DB -> Account -> String -> [Text.Text] -> BSAssoc -> RES
itemRoutes db user itemName path params = do
  case getOne $ (accountItems user) @= itemName of
    Just item -> case path of
      ["need"] ->
        needItem db user item
      ["got"] ->
        gotItem db user item
      ["delete"] ->
        deleteItem db user item
      ["comment"] ->
        withParams params ["comment"] $ commentItem db user item . head
      ["count"] ->
        withParams params ["count"] changeCount
        where changeCount [ct] = case reads ct :: [(Integer, String)] of
                (count, _):_ -> countItem db user item count
                _ -> resError "Count needs to be readable as an Integer"
      _ -> res404
    Nothing -> resError "Invalid item"

----- Server start
main = do
  session <- Vault.newKey
  store <- mapStore_
  bracket (openLocalState initialDB) (createCheckpointAndClose)
    (\db -> run 3000 . withSession store (fromString "SESSION") def session $ routes db session)
Something went wrong with that request. Please try again.