path: root/bragi/bar.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runghc -p "haskellPackages.ghcWithPackages (p: with p; [ yesod persistent-postgresql ])"


{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ApplicativeDo              #-}
  

import Yesod
import Database.Persist.Postgresql
  
import Control.Monad.Logger (runStderrLoggingT)
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Trans.Maybe

import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.Format

import Data.Text (Text)
import qualified Data.Text as Text

import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Aeson
import Data.Traversable
import Data.Maybe
import Data.Bool
import Data.String (IsString(..))
import Data.Unique
import Data.List (sortOn)
import Data.Ord


share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Item
    kind Text
    bought Day Maybe
    expires Day Maybe
    opened Day Maybe
    deriving Show Eq
|]

instance Ord Item where
  x `compare` y = mconcat
                  [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
                  , itemOpened x `compare` itemOpened y
                  , itemExpires x `compare` itemExpires x
                  , itemKind x `compare` itemKind x
                  , itemBought x `compare` itemBought x
                  ]

instance ToJSON Item where
  toJSON Item{..} = object $
    [ "kind" .= itemKind
    ] ++ maybe [] (\x -> ["bought" .= x]) itemBought
    ++ maybe [] (\x -> ["expires" .= x]) itemExpires
    ++ maybe [] (\x -> ["opened" .= x]) itemOpened

instance FromJSON Item where
  parseJSON = withObject "Item" $ \obj -> do
    itemKind <- obj .: "kind"
    itemBought <- obj .:? "bought"
    itemExpires <- obj .:? "expires"
    itemOpened <- obj .:? "opened"
    return Item{..}
  
instance ToJSON (Entity Item) where
  toJSON = entityIdToJSON

instance FromJSON (Entity Item) where
  parseJSON = entityIdFromJSON

data ItemDiff = DiffKind Text
              | DiffBought (Maybe Day)
              | DiffExpires (Maybe Day)
              | DiffOpened (Maybe Day)

newtype ItemDiffs = ItemDiffs [ItemDiff]

instance FromJSON ItemDiffs where
  parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
    tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
    tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
    tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
    tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")

toUpdate :: ItemDiffs -> [Update Item]
toUpdate (ItemDiffs ds) = do
  x <- ds
  return $ case x of
    DiffKind t -> ItemKind =. t
    DiffBought d -> ItemBought =. d
    DiffExpires d -> ItemExpires =. d
    DiffOpened d -> ItemOpened =. d

  
data BarInventory = BarInventory
  { sqlPool :: ConnectionPool
  }

mkYesod "BarInventory" [parseRoutes|
/ InventoryR GET PUT POST
/#ItemId ItemR GET PUT PATCH DELETE
/#ItemId/open OpenItemR POST
/#ItemId/update UpdateItemR POST GET
/#ItemId/delete DeleteItemR POST
|]

instance Yesod BarInventory where
  approot = guessApproot

instance RenderMessage BarInventory FormMessage where
  renderMessage _ _ = defaultFormMessage

instance YesodPersist BarInventory where
  type YesodPersistBackend BarInventory = SqlBackend

  runDB action = runSqlPool action . sqlPool =<< getYesod


data ViewState = ViewState
  { errs :: [Text]
  , insertForm :: Maybe Widget
  , insertEncoding :: Maybe Enctype
  , stock :: [Entity Item]
  , updateItem :: Maybe ItemId
  , updateForm :: Maybe Widget
  , updateEncoding :: Maybe Enctype
  }



main = runStderrLoggingT . withPostgresqlPool "user=bar dbname=bar" 5 . runReaderT $ do
  sqlPool <- ask
  mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) sqlPool
  liftIO . warpEnv $ BarInventory{..}


itemFragment itemId = "item" <> show (fromSqlKey itemId)
  
itemForm :: Maybe Item -> Html -> MForm Handler (FormResult Item, Widget)
itemForm proto identView = do
  today <- utctDay <$> liftIO getCurrentTime
  
  (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto
  (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
  (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
  (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"

  let itemRes = do
        itemKind <- kindRes
        itemBought <- boughtRes
        itemExpires <- expiresRes
        itemOpened <- openedRes
        return Item{..}

  return . (itemRes, ) $ do
    toWidget
      [cassius|
              label.checkbox
                input
                  vertical-align: middle
                span
                  vertical-align: middle
              |]
    -- addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/extras/modernizr-custom.js"
    addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/polyfiller.js"
    addScriptRemote "https://cdn.jsdelivr.net/jquery/3.1.1/jquery.js"
    toWidget
      [julius|
             webshims.setOptions("forms-ext", {
               "widgets": {
                 "classes": "hide-dropdownbtn"
               }
             });
             webshims.activeLang("en-GB");
             webshims.polyfill("forms forms-ext");
             |]
    [whamlet|
            #{identView}
            <div .td>^{fvInput kindView}
            <div .td>^{boughtWidget}
            <div .td>^{expiresWidget}
            <div .td>^{openedWidget}
            |]
  where
    dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget)
    dayForm proto label = do
      today <- utctDay <$> liftIO getCurrentTime

      checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
      
      (fmap (fromMaybe False) -> isNothingRes, isNothingView) <-
        mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto
      (dayRes, dayView) <-
        mreq dayField "" . Just . fromMaybe today $ join proto

      let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes
      return . (res, ) $ do
        [whamlet|
                $newline never
                <div .table>
                  <div .tr>
                    <label for=#{checkboxId} .checkbox .td>
                      ^{fvInput isNothingView}
                      <span>
                        #{label}
                  <div .tr>
                    <div .td .dayInput>^{fvInput dayView}
                |]



getInventoryR, postInventoryR :: Handler TypedContent
postInventoryR = getInventoryR
getInventoryR = do
  ((insertResult, (Just -> insertForm)), (Just -> insertEncoding)) <- runFormPost $ itemForm Nothing

  errs <- case insertResult of 
    FormSuccess newItem -> [] <$ runDB (insert newItem)
    FormFailure errors -> return errors
    _ -> return []

  (sortOn entityVal -> stock) <- runDB $ selectList [] []

  selectRep $ do
    provideJson (stock :: [Entity Item])
    provideRep $ mainView ViewState
      { updateItem = Nothing
      , updateForm = Nothing
      , updateEncoding = Nothing
      , ..
      }

postUpdateItemR, getUpdateItemR :: ItemId -> Handler TypedContent
postUpdateItemR = getUpdateItemR
getUpdateItemR updateItem = do
  Just entity <- fmap (Entity updateItem) <$> runDB (get updateItem)
  
  ((updateResult, (Just -> updateForm)), (Just -> updateEncoding)) <- runFormPost . itemForm . Just $ entityVal entity

  errs <- case updateResult of 
    FormSuccess Item{..} -> [] <$ runDB (update updateItem [ ItemKind =. itemKind
                                                           , ItemBought =. itemBought
                                                           , ItemExpires =. itemExpires
                                                           , ItemOpened =. itemOpened
                                                           ])
    FormFailure errors -> return errors
    _ -> return []

  selectRep $ do
    provideRep $ case updateResult of
      FormSuccess _ -> redirect $ InventoryR :#: itemFragment updateItem :: Handler Html
      _ -> do
        (sortOn entityVal -> stock) <- runDB $ selectList [] []
        mainView ViewState
          { insertForm = Nothing
          , insertEncoding = Nothing
          , updateItem = Just updateItem
          , ..
          }
    provideJson ()

mainView :: ViewState -> Handler Html
mainView ViewState{..} = defaultLayout $ do 
    let
      dayFormat = formatTime defaultTimeLocale "%e. %b %y"
              
    setTitle "Bar Inventory"
    toWidget
      [cassius|
              .table
                display: table
              .table div
                vertical-align: middle
              .td
                display: table-cell
                text-align: center
                padding: 0.25em
              .tr
                display: table-row
              .tc
                display: table-caption
                padding: 0.25em
              .th
                display: table-cell
                font-variant: small-caps
                font-weight: bold
                text-align: center
                padding: 0.25em
              .kind
                display: table-cell
                text-align: left
                padding: 0.25em
              .table .table .td, .table .table .tc, .table .table .th, .table .table .kind
                padding: 0
              .error
                background-color: #fdd
                text-align: center
                color: #c00
                list-style-type: none
              button
                width: 6em
                display:inline-text
              .day hr
                width: 2em
                border: 1px solid #ddd
                border-style: solid none solid none
              .sepBelow > div, .sepAbove > div
                border: 2px none #ddd
              .sepBelow > div
                border-bottom-style: solid
              .sepAbove > div
                border-top-style: solid
              .color:nth-child(even)
                background-color: #f0f0f0
              .color:nth-child(odd)
                background-color: #fff
              body > div
                margin: 0 auto
              .table > h1
                display: table-caption
              h1
                font-size: 1.5em
                font-weight: bold
                font-variant: small-caps
                text-align: center
                margin:0 0 .5em 0
              |]
    toWidget
      [whamlet|
              <div .table>
                <h1>
                  Inventory
                $if not $ null errs
                  <ul .tc .error .sepBelow>
                  $forall e <- errs
                    <li>#{e}
                <div .tr .sepBelow>
                  <div .th>Description
                  <div .th>Bought
                  <div .th>Expires
                  <div .th>Opened
                  <div .th>Actions
                $maybe insertEncoding <- insertEncoding
                  $maybe insertForm <- insertForm
                    <form .tr .sepBelow action=@{InventoryR} method=post enctype=#{insertEncoding}>
                      ^{insertForm}
                      <div .td>
                        <button type=submit>
                          Insert
                $forall e@(Entity itemId Item{..}) <- stock
                  $with idN <- fromSqlKey itemId
                    $if and [ Just itemId == updateItem, isJust updateEncoding, isJust updateForm ]
                      $maybe updateEncoding <- updateEncoding
                        $maybe updateForm <- updateForm
                          <form .tr .color action=@{UpdateItemR itemId}##{itemFragment itemId} method=post enctype=#{updateEncoding} ##{itemFragment itemId}>
                            ^{updateForm}
                            <div .td>
                              <button type=submit>
                                Save Changes
                    $else
                      <div .tr .color ##{itemFragment itemId}>
                        <div .kind>#{itemKind}
                        <div .td .day>
                          $maybe bought <- itemBought
                            #{dayFormat bought}
                          $nothing
                            <hr>
                        <div .td .day>
                          $maybe expires <- itemExpires
                            #{dayFormat expires}
                          $nothing
                            <hr>
                        <div .td .day>
                          $maybe opened <- itemOpened
                            #{dayFormat opened}
                          $nothing
                            <form method=post action=@{OpenItemR itemId}>
                              <button type=submit>
                                Open
                        <div .td>
                          <form method=get action=@{UpdateItemR itemId}##{itemFragment itemId}>
                            <button type=submit>
                              Alter
                          <form method=post action=@{DeleteItemR itemId}>
                            <button type=submit>
                              Delete
              |]

putInventoryR :: Handler Value
putInventoryR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item)

getItemR :: ItemId -> Handler TypedContent
getItemR itemId = do
  let getEntity id = fmap (Entity id) <$> get id

  eLookup <- runDB $ getEntity itemId

  case eLookup of
    Nothing -> notFound
    Just entity -> do
      
      selectRep $ do
        provideJson entity

patchItemR :: ItemId -> Handler Value
patchItemR itemId = do
  diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
  returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)

putItemR :: ItemId -> Handler Value
putItemR itemId = do
  Item{..} <- requireCheckJsonBody
  returnJson . Entity itemId =<< runDB
    (updateGet itemId [ ItemKind =. itemKind
                      , ItemBought =. itemBought
                      , ItemExpires =. itemExpires
                      , ItemOpened =. itemOpened
                      ])

deleteItemR :: ItemId -> Handler ()
deleteItemR = runDB . delete

postDeleteItemR :: ItemId -> Handler TypedContent
postDeleteItemR itemId = do
  runDB $ delete itemId
  selectRep $ do
    provideJson ()
    provideRep (redirect $ InventoryR :: Handler Html)

postOpenItemR :: ItemId -> Handler TypedContent
postOpenItemR itemId = do
  today <- utctDay <$> liftIO getCurrentTime
  result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today
                                                            ]
  selectRep $ do
    provideJson result
    provideRep (redirect $ InventoryR :#: itemFragment itemId :: Handler Html)