gdritter repos inf-dict / master src / Main.hs
master

Tree @master (Download .tar.gz)

Main.hs @master — raw · history · blame 

 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
module Main where

import Control.Monad.IO.Class
import Database.SQLite.Simple (Connection, open)
import Data.Monoid ((<>))
import Data.Text (pack)
import Network.HTTP.Types.Status (status404)
import Network.Wai.Middleware.Static (staticPolicy, hasPrefix)
import System.Environment (lookupEnv)
import Web.Spock
import Web.Spock.Config

import Render
import Types

respondWith :: MonadIO m => [Entry] -> ActionCtxT ctx m ()
respondWith es = do
  pref <- preferredFormat
  case pref of
    PrefJSON -> json es
    _        -> html (rPage (rEntries es))

db :: MonadIO m => DB a -> ActionCtxT Connection m a
db mote = do
  conn <- getContext
  liftIO (mote conn)

unwrap :: MonadIO m => Maybe a -> (a -> ActionCtxT ctx m ()) -> ActionCtxT ctx m ()
unwrap Nothing  _ = setStatus status404
unwrap (Just x) f = f x

main :: IO ()
main = do
  dbLoc <- maybe "test.db" id `fmap` lookupEnv "DB_LOC"
  port <- maybe 8080 read `fmap` lookupEnv "PORT"
  conn <- open dbLoc
  spockCfg <- defaultSpockCfg () PCNoDatabase ()
  runSpock port $ spock spockCfg $ prehook (return conn) $ do
    middleware $ staticPolicy (mempty <> hasPrefix "static")

    get root $ do
      html (rPage "welcome to the dictionary yo")

    get "add" $ do
      ls <- db allLanguages
      html (rPage (rAdd ls))

    get "search" $ do
      html (rPage rSearch)

    get ("lang") $ do
      ls <- db allLanguages
      html (rPage (rLangList ls))

    get ("lang" <//> var) $ \ lang -> do
      es <- db (getWordsByLanguage lang)
      respondWith es

    get "word" $ do
      es <- db getAllWords
      respondWith es
    post "word" $ do
      ps <- paramsToEntry <$> params
      unwrap ps $ \ e -> do
        i <- db (addWord e)
        redirect (pack ("/word/" ++ show i))

    get ("word" <//> var) $ \ w -> do
      eM <- db (getWordById w)
      unwrap eM $ \ e -> respondWith [e]
    post ("word" <//> var) $ \ w -> do
      ps <- paramsToEntry <$> params
      unwrap ps $ \ e -> do
          db (updateWord w e)
          redirect (pack ("/word/" ++ show w))

    get ("word" <//> var <//> "edit") $ \ w -> do
      eM <- db (getWordById w)
      ls <- db allLanguages
      unwrap eM $ html . rPage . rEdit w ls

    get ("word" <//> "search" <//> var) $ \ t -> do
      db (searchAll t) >>= respondWith

    get ("word" <//> "search" <//> "by-word" <//> var) $ \ t -> do
      db (searchWord t) >>= respondWith

    get ("word" <//> "search" <//> "by-meaning" <//> var) $ \ t -> do
      db (searchMeaning t) >>= respondWith