car-pool (empty) → 0.0
raw patch · 4 files changed
+324/−0 lines, 4 filesdep +basedep +blaze-htmldep +containerssetup-changed
Dependencies added: base, blaze-html, containers, digestive-functors, digestive-functors-blaze, digestive-functors-happstack, explicit-exception, happstack-server, non-empty, spreadsheet, text, transformers, utility-ht
Files
- LICENSE +26/−0
- Setup.lhs +3/−0
- car-pool.cabal +42/−0
- src/Main.hs +253/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ car-pool.cabal view
@@ -0,0 +1,42 @@+Name: car-pool+Version: 0.0+License: BSD3+License-File: LICENSE+Author: Henning Thielemann+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+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
+ src/Main.hs view
@@ -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