2016-02-02 14:50:30 +03:00
|
|
|
{-# LANGUAGE
|
|
|
|
OverloadedStrings,
|
2016-02-02 19:29:23 +03:00
|
|
|
TemplateHaskell,
|
|
|
|
RecordWildCards,
|
|
|
|
RankNTypes,
|
2016-02-02 14:50:30 +03:00
|
|
|
NoImplicitPrelude
|
|
|
|
#-}
|
|
|
|
|
|
|
|
|
2016-02-02 12:35:39 +03:00
|
|
|
module Main (main) where
|
|
|
|
|
2016-02-02 14:50:30 +03:00
|
|
|
|
|
|
|
-- General
|
2016-02-02 19:29:23 +03:00
|
|
|
import BasePrelude hiding (Category)
|
|
|
|
-- Lenses
|
|
|
|
import Lens.Micro.Platform
|
2016-02-02 14:50:30 +03:00
|
|
|
-- IO
|
|
|
|
import Control.Monad.IO.Class
|
|
|
|
-- Text
|
|
|
|
import Data.Text (Text)
|
2016-02-02 19:29:23 +03:00
|
|
|
import qualified Data.Text as T
|
2016-02-02 14:50:30 +03:00
|
|
|
import qualified Data.Text.Lazy as TL
|
2016-02-02 19:29:23 +03:00
|
|
|
import Data.Text.Format hiding (format)
|
|
|
|
import qualified Data.Text.Format as Format
|
|
|
|
import Data.Text.Format.Params (Params)
|
2016-02-02 14:50:30 +03:00
|
|
|
-- Web
|
2016-02-02 19:29:23 +03:00
|
|
|
import Lucid hiding (for_)
|
2016-02-02 14:50:30 +03:00
|
|
|
import Web.Spock
|
2016-02-02 19:29:23 +03:00
|
|
|
import Network.Wai.Middleware.Static
|
2016-02-02 14:50:30 +03:00
|
|
|
|
|
|
|
|
2016-02-02 19:29:23 +03:00
|
|
|
data Category = Category {
|
|
|
|
_categoryId :: Int,
|
|
|
|
_categoryTitle :: Text,
|
|
|
|
_categoryItems :: [Text] }
|
|
|
|
|
|
|
|
makeLenses ''Category
|
|
|
|
|
|
|
|
data S = S {
|
|
|
|
_nextId :: Int,
|
|
|
|
_categories :: [Category] }
|
|
|
|
|
|
|
|
makeLenses ''S
|
|
|
|
|
|
|
|
categoryById :: Int -> Traversal' S Category
|
|
|
|
categoryById catId = categories . each . filtered ((== catId) . _categoryId)
|
|
|
|
|
2016-02-02 12:35:39 +03:00
|
|
|
main :: IO ()
|
2016-02-02 14:50:30 +03:00
|
|
|
main = runSpock 8080 $ spockT id $ do
|
2016-02-02 19:29:23 +03:00
|
|
|
middleware (staticPolicy (addBase "static"))
|
|
|
|
stateVar <- liftIO $ newIORef S {
|
|
|
|
_nextId = 0,
|
|
|
|
_categories = [] }
|
2016-02-02 14:50:30 +03:00
|
|
|
get root $ do
|
2016-02-02 19:29:23 +03:00
|
|
|
s <- liftIO $ readIORef stateVar
|
2016-02-02 19:41:28 +03:00
|
|
|
lucid $ renderRoot s
|
2016-02-02 19:29:23 +03:00
|
|
|
post "/add/category" $ do
|
|
|
|
title <- param' "title"
|
|
|
|
thisId <- liftIO $ view nextId <$> readIORef stateVar
|
|
|
|
let newCategory = Category {
|
|
|
|
_categoryId = thisId,
|
|
|
|
_categoryTitle = title,
|
|
|
|
_categoryItems = [] }
|
|
|
|
liftIO $ modifyIORef stateVar $
|
|
|
|
(categories %~ (++ [newCategory])) .
|
|
|
|
(nextId %~ succ)
|
2016-02-02 19:41:28 +03:00
|
|
|
lucid $ renderCategory newCategory
|
2016-02-02 19:29:23 +03:00
|
|
|
post ("/add/item" <//> var) $ \catId -> do
|
|
|
|
item <- param' "item"
|
|
|
|
-- TODO: maybe do something if the category doesn't exist (e.g. has been
|
|
|
|
-- already deleted)
|
|
|
|
liftIO $ modifyIORef stateVar $
|
|
|
|
categoryById catId . categoryItems %~ (++ [item])
|
|
|
|
|
2016-02-02 19:41:28 +03:00
|
|
|
renderRoot :: S -> Html ()
|
|
|
|
renderRoot s = do
|
2016-02-02 19:29:23 +03:00
|
|
|
loadJS "https://ajax.googleapis.com/ajax/libs/jquery/2.2.0/jquery.min.js"
|
|
|
|
loadJS "/js.js"
|
|
|
|
div_ [id_ "categories"] $ do
|
2016-02-02 19:41:28 +03:00
|
|
|
mapM_ renderCategory (s ^. categories)
|
2016-02-02 20:14:02 +03:00
|
|
|
let handler = "if (event.keyCode == 13) {\
|
|
|
|
\ addCategory(this.value);\
|
|
|
|
\ this.value = ''; }"
|
|
|
|
input_ [type_ "text", placeholder_ "new category", onkeyup_ handler]
|
2016-02-02 14:50:30 +03:00
|
|
|
|
2016-02-02 19:41:28 +03:00
|
|
|
renderCategory :: Category -> Html ()
|
|
|
|
renderCategory Category{..} =
|
|
|
|
div_ [id_ (format "cat{}" [_categoryId])] $ do
|
|
|
|
h2_ (toHtml _categoryTitle)
|
|
|
|
ul_ $ do
|
|
|
|
mapM_ (li_ . toHtml) _categoryItems
|
2016-02-02 20:14:02 +03:00
|
|
|
let handler = format "if (event.keyCode == 13) {\
|
|
|
|
\ addItem({}, this.value);\
|
|
|
|
\ this.value = ''; }"
|
|
|
|
[_categoryId]
|
|
|
|
input_ [type_ "text", placeholder_ "new item", onkeyup_ handler]
|
2016-02-02 19:41:28 +03:00
|
|
|
|
2016-02-02 14:50:30 +03:00
|
|
|
-- Utils
|
|
|
|
|
2016-02-02 19:29:23 +03:00
|
|
|
loadJS :: Text -> Html ()
|
|
|
|
loadJS url = with (script_ "") [src_ url]
|
|
|
|
|
2016-02-02 14:50:30 +03:00
|
|
|
lucid :: Html a -> ActionT IO a
|
|
|
|
lucid = html . TL.toStrict . renderText
|
2016-02-02 19:29:23 +03:00
|
|
|
|
|
|
|
-- | Format a string (a bit 'Text.Printf.printf' but with different syntax).
|
|
|
|
format :: Params ps => Format -> ps -> Text
|
|
|
|
format f ps = TL.toStrict (Format.format f ps)
|