car-pool-0.0: src/Main.hs

-- module Main (main) where

import Text.Digestive (Form, View, text, bool, subView, check, (.:))
import Text.Digestive.Blaze.Html5
          (inputText, inputCheckbox, inputSubmit, label, form, errorList)
import Text.Digestive.Happstack (runForm)

import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Html5 as H
import qualified Happstack.Server as Happstack

import qualified Data.Spreadsheet as Spreadsheet
import qualified Control.Monad.Exception.Asynchronous as AsyncExc

import qualified Control.Monad.Trans.State as MS
import Control.Monad.IO.Class (MonadIO, liftIO)

import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Map as Map; import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as T
import Data.Maybe.HT (toMaybe)
import Data.Maybe (catMaybes)
import Data.Text (Text)

import qualified Data.Foldable as Fold
import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>))
import Data.Traversable (traverse)
import Data.Foldable (forM_)
import Data.Monoid (mappend, mconcat)

import qualified System.IO as IO


data Place = Place
   { placeName :: Text
   , placeContact :: Text
   , placeOffer, placeRequest :: Bool
   } deriving (Show)

t :: String -> Text
t = T.pack

h :: String -> H.Html
h = H.toHtml

idAnyTown, idTowns, idOther, idMail,
   idOffer, idRequest, idOfferRequest :: Text
idAnyTown = t"anytown"
idTowns   = t"town"
idOther   = t"other"
idMail    = t"mail"
idOffer   = t"offer"
idRequest = t"request"
idOfferRequest = t"or"

idFromTown :: Text -> Text
idFromTown = T.map Char.toLower . T.filter Char.isAlpha

placeForm :: Monad m => [Text] -> Form Text m [Place]
placeForm oldTowns =
   pure
      (\newTowns mail (offer, request) ->
          map (\town -> Place town mail offer request) newTowns)
   <*> townsForm oldTowns
   <*> idMail .: check (t"Bitte E-Mail oder Telefonnummer angeben.") checkMail (text Nothing)
   <*> offerRequestForm

townsForm :: Monad m => [Text] -> Form Text m [Text]
townsForm towns =
   (idAnyTown .:) $
   check (t"Bitte mindestens eine Stadt ausw\228hlen.") (not . null) $
   fmap catMaybes $
   pure (:)
   <*> idOther .:
       fmap (\other -> toMaybe (not $ T.null other) other) (text Nothing)
   <*> idTowns .:
       traverse
          (\town -> flip toMaybe town <$> (idFromTown town .: bool Nothing))
          towns

offerRequestForm :: Monad m => Form Text m (Bool, Bool)
offerRequestForm =
   (idOfferRequest .:) $
   check (t"Bitte mindestens Gebot oder Gesuch w\228hlen.") (uncurry (||)) $
   liftA2 (,)
      (idOffer .: bool Nothing)
      (idRequest .: bool Nothing)


checkMail :: Text -> Bool
checkMail = not . T.null


type Parser a = MS.State [String] a

parseField :: a -> (String -> a) -> Parser a
parseField deflt convert =
   MS.state $ \xt ->
   case xt of
      [] -> (deflt, [])
      x:xs -> (convert x, xs)

runParser :: Parser a -> [String] -> a
runParser = MS.evalState

placeFromLine :: [String] -> Place
placeFromLine =
   runParser $
   pure Place
      <*> parseField T.empty T.pack
      <*> parseField T.empty T.pack
      <*> parseField False (not . null)
      <*> parseField False (not . null)

lineFromPlace :: Place -> [String]
lineFromPlace p =
   T.unpack (placeName p) :
   T.unpack (placeContact p) :
   csvFromBool (placeOffer p) :
   csvFromBool (placeRequest p) :
   []


placeView :: View H.Html -> [Text] -> H.Html
placeView view towns = do
   H.h2 $ h"Mitfahrgelegenheit"

   errorList idAnyTown view
   H.table $ do
      let tview = subView idAnyTown view

      forM_ towns $ \town -> H.tr $ do
         let idTown = idFromTown town
             sview = subView idTowns tview
         H.td $ inputCheckbox idTown sview -- H.! H.align "right"
         H.td $ label         idTown sview (H.toHtml town)

      H.tr $ do
         H.td $ label     idOther tview (h"andere Stadt: ")
         H.td $ inputText idOther tview

   errorList idMail view
   label     idMail view (h"Kontakt: ")
   inputText idMail view
   H.br

   errorList idOfferRequest view
   case subView idOfferRequest view of
      sview -> do
         label         idOffer sview (h"Gebot: ")
         inputCheckbox idOffer sview
         label         idRequest sview (h"Gesuch: ")
         inputCheckbox idRequest sview
         H.br

readCSV ::
   ([Place] -> Happstack.ServerPart Happstack.Response) ->
   Happstack.ServerPart Happstack.Response
readCSV f = do
   csv <- liftIO $ readFile csvPath
   case Spreadsheet.fromString '"' ',' csv of
      AsyncExc.Exceptional mmsg table ->
         case mmsg of
            Just msg -> do
               liftIO $ IO.hPutStrLn IO.stderr msg
               Happstack.internalServerError $
                  Happstack.toResponse "Cannot read database."
            Nothing ->
               f $ map placeFromLine table

groupPlaces :: [Place] -> Map Text (NonEmpty.T [] Place)
groupPlaces =
   Map.fromListWith NonEmptyC.append .
   map (\place -> (placeName place, NonEmpty.singleton place))

htmlFromContact :: Text -> H.Html
htmlFromContact contact =
   case T.find ('@'==) contact of
      Nothing -> H.toHtml contact
      Just _ ->
         H.a (H.toHtml contact)
            H.! (HA.href $ H.toValue $ mappend (t"mailto:") contact)

htmlFromContacts :: Text -> H.Html
htmlFromContacts =
   mconcat . List.intersperse (H.toHtml ", ") .
   map htmlFromContact . T.split (','==)

htmlFromPlaces :: Map Text (NonEmpty.T [] Place) -> H.Html
htmlFromPlaces places =
   H.table $ do
      H.tr $ mapM_ (H.th . h) $
         "Stadt" : "Kontakt" : "Gebot" : "Gesuch" : []
      Fold.sequence_ $ flip Map.mapWithKey places $ \town (NonEmpty.Cons contact contacts) ->
         let row place = do
                H.td $ htmlFromContacts $ placeContact place
                H.td $ htmlFromBool $ placeOffer place
                H.td $ htmlFromBool $ placeRequest place
         in  do H.tr $ do
                   H.td $ H.toHtml town
                   row contact
                forM_ contacts $ \c -> H.tr $ do
                   H.td $ h""
                   row c

site :: Happstack.ServerPart Happstack.Response
site = readCSV $ \places -> do
   Happstack.decodeBody $ Happstack.defaultBodyPolicy "/tmp" 4096 4096 4096
   let towns = Set.toAscList $ Set.fromList $ map placeName places
   r <- runForm (t"carpool") $ placeForm towns
   case r of
      (view, Nothing) -> do
         let htmlView = fmap H.toHtml view
         Happstack.ok $ Happstack.toResponse $
            template $ do
               H.h1 $ h title
               htmlFromPlaces $ groupPlaces places
               form htmlView (t"/") $ do
                  placeView htmlView towns
                  H.br
                  inputSubmit $ t"Anmelden"
      (_, Just newPlaces) -> do
         liftIO $ appendFile csvPath $
            Spreadsheet.toString '"' ',' $ map lineFromPlace newPlaces
         Happstack.ok $ Happstack.toResponse $
            template $ do
               H.h1 $ h"Anmeldung erhalten:"
               htmlFromPlaces $ groupPlaces newPlaces

title :: String
title =
   "Mitfahrb\246rse zur ordentlichen Mitgliederversammlung des Bundes der Versicherten, 2014-09-27"

template :: H.Html -> H.Html
template body = H.docTypeHtml $ do
   H.head $ H.title $ h title
   H.body body

htmlFromBool :: Bool -> H.Html
htmlFromBool b = h $ if b then "x" else ""

csvFromBool :: Bool -> String
csvFromBool b = if b then "x" else ""

csvPath :: FilePath
csvPath = "carpool.csv"

main :: IO ()
main = Happstack.simpleHTTP (Happstack.nullConf{Happstack.port=8080}) site