104 lines
3.6 KiB
Haskell
104 lines
3.6 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Monad (liftM2)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.Aeson (ToJSON (..))
|
|
import qualified Data.Map as Map (fromList, lookup)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import GHC.Generics (Generic)
|
|
import Network.HTTP.Client (Manager)
|
|
import Network.HTTP.Client.TLS (newTlsManager)
|
|
import Network.Wai.Handler.Warp (runEnv)
|
|
import Onomap.Stoepel
|
|
import Onomap.Svg (renderMap)
|
|
import Onomap.Types
|
|
import Servant
|
|
import Servant.HTML.Blaze (HTML)
|
|
import Text.Blaze (ToMarkup (..))
|
|
|
|
data Response = Response {color :: [Text], areas :: [Area], statistics :: [(Text, ByArea Double)], svgSettings :: SvgSettings}
|
|
deriving (Generic)
|
|
|
|
instance ToMarkup Response where
|
|
toMarkup response =
|
|
preEscapedToMarkup $
|
|
renderMap
|
|
(svgSettings response)
|
|
(color response)
|
|
(areas response)
|
|
(statistics response)
|
|
|
|
instance ToJSON Response where
|
|
toJSON response =
|
|
toJSON $
|
|
Map.fromList $
|
|
map
|
|
( \area ->
|
|
( name area
|
|
, Map.fromList $
|
|
("population", toJSON $ population area) :
|
|
map
|
|
( \(surname, stats) ->
|
|
( surname
|
|
, toJSON $ Map.lookup (key area) (getByArea stats)
|
|
)
|
|
)
|
|
(statistics response)
|
|
)
|
|
)
|
|
(areas response)
|
|
|
|
type OnomapApi =
|
|
Capture "mode" Mode
|
|
:> QueryParams "name" Text
|
|
:> QueryParam "by" AreaKind
|
|
:> QueryParams "color" Text
|
|
:> QueryParam "scale" ScaleToMaximum
|
|
:> Get '[HTML] Response
|
|
|
|
app :: Manager -> ([Area], [Area]) -> Application
|
|
app manager' (theDistricts, theStates) = serve onomapApi server
|
|
where
|
|
server :: Server OnomapApi
|
|
server = \mode (surnames :: [Text]) maybeAreaKind colors scaleTo ->
|
|
liftIO $
|
|
runStoepel manager' $ do
|
|
let areaMode = fromMaybe District maybeAreaKind
|
|
computeFunction =
|
|
case mode of
|
|
Relative -> relativeCount
|
|
Absolute -> absoluteCount
|
|
theAreas = case areaMode of
|
|
State -> theStates
|
|
District -> theDistricts
|
|
theNames = map Just surnames
|
|
theStats <- case areaMode of
|
|
State -> mapM stateStatistics theNames
|
|
District -> mapM districtStatistics theNames
|
|
let stats = map (computeAreaStatistics computeFunction theAreas) theStats
|
|
return
|
|
Response
|
|
{ color = colors ++ defaultColorPalette
|
|
, areas = theAreas
|
|
, svgSettings = SvgSettings{scaleToMaximum = fromMaybe Global scaleTo}
|
|
, statistics = zip surnames stats
|
|
}
|
|
onomapApi :: Proxy OnomapApi
|
|
onomapApi = Proxy
|
|
|
|
main :: IO ()
|
|
main = do
|
|
manager' <- newTlsManager
|
|
runEnv 8081 . app manager' =<< runStoepel manager' (liftM2 (,) districts states)
|