diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) Henning Thielemann 2013 +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/car-pool.cabal b/car-pool.cabal new file mode 100644 --- /dev/null +++ b/car-pool.cabal @@ -0,0 +1,42 @@ +Name: car-pool +Version: 0.0 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://code.haskell.org/~thielema/car-pool/ +Category: Web +Synopsis: Simple web-server for organizing car-pooling for an event +Description: Simple web-server for organizing car-pooling for an event +Tested-With: GHC==6.12.1, GHC==7.4.2 +Cabal-Version: >=1.8 +Build-Type: Simple + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: http://code.haskell.org/~thielema/car-pool/ + +Source-Repository head + Type: darcs + Location: http://code.haskell.org/~thielema/car-pool/ + +Executable car-pool + Build-Depends: + spreadsheet >=0.1.3 && <0.2, + transformers >=0.2 && <0.5, + explicit-exception >=0.1.7 && <0.2, + blaze-html >=0.5 && <0.6, + digestive-functors-blaze >=0.6 && <0.7, + digestive-functors-happstack >=0.6 && <0.7, + digestive-functors >=0.6.1 && <0.7, + happstack-server >=7.0 && <7.1, + text >=0.11 && <0.12, + non-empty >=0.1 && <0.3, + containers >=0.3 && <0.6, + utility-ht >=0.0.1 && <0.1, + base >=4 && <5 + + GHC-Options: -Wall -threaded + Hs-Source-Dirs: src + Main-Is: Main.hs diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,253 @@ +-- 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