diff --git a/onomastics-ng/app/Types.hs b/onomastics-ng/app/Types.hs deleted file mode 100644 index 349e646..0000000 --- a/onomastics-ng/app/Types.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} - -module Types (Area (..), AreaKind (..), ByArea (..), relativeCount, absoluteCount, computeAreaStatistics) where - -import Control.Arrow ((&&&)) -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Foldable (toList) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Vector ((!)) -import GHC.Generics - -data AreaKind = District | State - -newtype Key (t :: AreaKind) = Key {getKey :: Text} - deriving (Show, Generic, Eq, Ord) - -instance FromJSON (Key t) where - parseJSON = withText "Area key" (pure . Key) - -data Area (t :: AreaKind) = Area - { name :: Text - , key :: Key t - , population :: Int - , path :: Text - } - deriving (Show, Generic) - -instance FromJSON (Area t) - -newtype ByArea (t :: AreaKind) n = ByArea {getByArea :: Map (Key t) n} - deriving (Show) - -instance FromJSON (ByArea 'District Int) where - parseJSON = parseClusters "DistrictClusterer" - -instance FromJSON (ByArea 'State Int) where - parseJSON = parseClusters "StateClusterer" - -parseClusters :: Text -> Value -> Parser (ByArea t Int) -parseClusters clusterType = - withObject "Statistics" $ \o -> - ((o .: "clusterers") >>= (.: clusterType) >>= (.: "Data")) - >>= withArray - "Clusters" - ( \a -> - ByArea . Map.fromList . toList - <$> mapM - ( withArray - "Cluster" - ( \kv -> - withText - "Key" - ( \k -> - withScientific - "Value" - (\v -> return (Key k, truncate v)) - (kv ! 1) - ) - (kv ! 0) - ) - ) - a - ) - -computeAreaStatistics :: (Area t -> Int -> a) -> [Area t] -> ByArea t Int -> ByArea t a -computeAreaStatistics f areas nameCounts = - ByArea . Map.fromList $ map (key &&& areaCount) areas - where - areaCount area = - let nameCount = fromMaybe 0 (Map.lookup (key area) (getByArea nameCounts)) - in f area nameCount - -absoluteCount, relativeCount :: Area t -> Int -> Double -absoluteCount _ count = fromIntegral count -relativeCount area count = million * (fromIntegral count / fromIntegral (population area)) - where - million = 10 ** 6 diff --git a/onomastics-ng/app/Main.hs b/onomastics-ng/cli/Main.hs similarity index 68% rename from onomastics-ng/app/Main.hs rename to onomastics-ng/cli/Main.hs index 46ea0f1..91d7191 100644 --- a/onomastics-ng/app/Main.hs +++ b/onomastics-ng/cli/Main.hs @@ -5,13 +5,12 @@ module Main where import Data.Maybe (fromMaybe) import Data.Text (Text) +import qualified Data.Text.IO as Text import Network.HTTP.Client.TLS (newTlsManager) +import Onomap.Stoepel +import Onomap.Svg +import Onomap.Types import Options.Applicative -import Stoepel -import Svg -import Types - -data Mode = Relative | Absolute data Options = Options { mode :: Mode @@ -41,13 +40,13 @@ main = do Absolute -> absoluteCount color = fromMaybe "black" $ fillColor options res <- runStoepel manager' $ do - case areaMode options of - State -> do - ds <- states - stats <- computeAreaStatistics computeFunction ds <$> stateStatistics (Just $ surname options) - return $ drawMap color ds stats - District -> do - ds <- districts - stats <- computeAreaStatistics computeFunction ds <$> districtStatistics (Just $ surname options) - return $ drawMap color ds stats - print res + let theName = Just $ surname options + ds <- case areaMode options of + State -> states + District -> districts + theStats <- case areaMode options of + State -> stateStatistics theName + District -> districtStatistics theName + let stats = computeAreaStatistics computeFunction ds theStats + return $ renderMap color ds stats + Text.putStrLn res diff --git a/onomastics-ng/app/Stoepel.hs b/onomastics-ng/lib/Onomap/Stoepel.hs similarity index 60% rename from onomastics-ng/app/Stoepel.hs rename to onomastics-ng/lib/Onomap/Stoepel.hs index f030e31..0311ac9 100644 --- a/onomastics-ng/app/Stoepel.hs +++ b/onomastics-ng/lib/Onomap/Stoepel.hs @@ -1,28 +1,28 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -module Stoepel (districts, districtStatistics, states, stateStatistics, runStoepel) where +module Onomap.Stoepel (districts, districtStatistics, states, stateStatistics, runStoepel) where import Data.Proxy import Data.Text (Text) import Network.HTTP.Client (Manager) import Servant.API import Servant.Client -import Types (Area, AreaKind (..), ByArea) +import Onomap.Types (Area, ByArea) type StoepelAPI = - "content" :> "de" :> "districts.json" :> Get '[JSON] [Area 'District] - :<|> "api" :> "clusters" :> "district" :> QueryParam "name" Text :> Get '[JSON] (ByArea 'District Int) - :<|> "content" :> "de" :> "states.json" :> Get '[JSON] [Area 'State] - :<|> "api" :> "clusters" :> "state" :> QueryParam "name" Text :> Get '[JSON] (ByArea 'State Int) + "content" :> "de" :> "districts.json" :> Get '[JSON] [Area] + :<|> "api" :> "clusters" :> "district" :> QueryParam "name" Text :> Get '[JSON] (ByArea Int) + :<|> "content" :> "de" :> "states.json" :> Get '[JSON] [Area] + :<|> "api" :> "clusters" :> "state" :> QueryParam "name" Text :> Get '[JSON] (ByArea Int) stoepelApi :: Proxy StoepelAPI stoepelApi = Proxy -districts :: ClientM [Area 'District] -states :: ClientM [Area 'State] -districtStatistics :: Maybe Text -> ClientM (ByArea 'District Int) -stateStatistics :: Maybe Text -> ClientM (ByArea 'State Int) +districts :: ClientM [Area] +states :: ClientM [Area] +districtStatistics :: Maybe Text -> ClientM (ByArea Int) +stateStatistics :: Maybe Text -> ClientM (ByArea Int) districts :<|> districtStatistics :<|> states :<|> stateStatistics = client stoepelApi runStoepel :: Manager -> ClientM a -> IO a diff --git a/onomastics-ng/app/Svg.hs b/onomastics-ng/lib/Onomap/Svg.hs similarity index 88% rename from onomastics-ng/app/Svg.hs rename to onomastics-ng/lib/Onomap/Svg.hs index e863c35..9792a0c 100644 --- a/onomastics-ng/app/Svg.hs +++ b/onomastics-ng/lib/Onomap/Svg.hs @@ -1,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -module Svg (drawMap) where +module Onomap.Svg (drawMap, renderMap) where import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Text (Text) +import Data.Text.Lazy (toStrict) import qualified Data.Text as Text import Graphics.Svg import Text.Printf (printf) -import Types (Area (..), ByArea (..)) +import Onomap.Types (Area (..), ByArea (..)) -drawMap :: Text -> [Area t] -> ByArea t Double -> Element +renderMap :: Text -> [Area] -> ByArea Double -> Text +renderMap fillColor areas statistics = toStrict $ prettyText $ drawMap fillColor areas statistics + +drawMap :: Text -> [Area] -> ByArea Double -> Element drawMap fillColor areas statistics = doctype <> with (svg11_ content) [Version_ <<- "1.1", Width_ <<- "650", Height_ <<- "900"] where diff --git a/onomastics-ng/lib/Onomap/Types.hs b/onomastics-ng/lib/Onomap/Types.hs new file mode 100644 index 0000000..00736f1 --- /dev/null +++ b/onomastics-ng/lib/Onomap/Types.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module Onomap.Types (Area (..), AreaKind (..), ByArea (..), relativeCount, absoluteCount, computeAreaStatistics, Mode(..)) where + +import Control.Arrow ((&&&)) +import Data.Aeson +import Control.Applicative (Alternative(..)) +import Data.Foldable (toList) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Vector ((!)) +import GHC.Generics +import Servant.API + +data Mode = Relative | Absolute + +instance FromHttpApiData Mode where + parseUrlPiece = \case + "relative" -> Right Relative + "absolute" -> Right Absolute + x -> Left x + +data AreaKind = District | State + +instance FromHttpApiData AreaKind where + parseUrlPiece = \case + "district" -> Right District + "state" -> Right State + x -> Left x + +data Area = Area + { name :: Text + , key :: Text + , population :: Int + , path :: Text + } + deriving (Show, Generic) + +instance FromJSON Area +instance ToJSON Area + +newtype ByArea n = ByArea {getByArea :: Map Text n} + deriving (Show) + +instance ToJSON a => ToJSON (ByArea a) where + toJSON = toJSON . getByArea + +instance (Integral a, FromJSON a) => FromJSON (ByArea a) where + parseJSON = + withObject "Statistics" $ \o -> do + clusterers <- o .: "clusterers" + clusterer <- clusterers .: "DistrictClusterer" <|> clusterers .: "StateClusterer" + data_ <- clusterer .: "Data" + withArray + "Clusters" + ( \a -> + ByArea . Map.fromList . toList + <$> mapM + ( withArray + "Cluster" + ( \kv -> + withText + "Key" + ( \k -> + withScientific + "Value" + (\v -> return (k, truncate v)) + (kv ! 1) + ) + (kv ! 0) + ) + ) + a + ) + data_ + +computeAreaStatistics :: (Area -> Int -> a) -> [Area] -> ByArea Int -> ByArea a +computeAreaStatistics f areas nameCounts = + ByArea . Map.fromList $ map (key &&& areaCount) areas + where + areaCount area = + let nameCount = fromMaybe 0 (Map.lookup (key area) (getByArea nameCounts)) + in f area nameCount + +absoluteCount, relativeCount :: Area -> Int -> Double +absoluteCount _ count = fromIntegral count +relativeCount area count = million * (fromIntegral count / fromIntegral (population area)) + where + million = 10 ** 6 diff --git a/onomastics-ng/onomap.cabal b/onomastics-ng/onomap.cabal index 5844661..3c1c1d5 100644 --- a/onomastics-ng/onomap.cabal +++ b/onomastics-ng/onomap.cabal @@ -4,22 +4,50 @@ version: 0.1.0 author: Kierán Meinhardt maintainer: kmein@posteo.de -executable onomap - main-is: Main.hs +library + hs-source-dirs: lib + exposed-modules: Onomap.Stoepel + , Onomap.Types + , Onomap.Svg build-depends: base ^>=4.14.3.0 - , aeson - , containers , http-client - , http-client-tls - , optparse-applicative , servant , servant-client + , aeson , svg-builder - , text , vector - other-modules: Stoepel - , Types - , Svg - hs-source-dirs: app + , containers + , text + default-language: Haskell2010 + ghc-options: -O2 -Wall -threaded + +executable onomap-cli + main-is: Main.hs + build-depends: base ^>=4.14.3.0 + , onomap + , optparse-applicative + , text + , http-client-tls + hs-source-dirs: cli + default-language: Haskell2010 + ghc-options: -O2 -Wall -threaded + + +executable onomap-web + main-is: Main.hs + build-depends: base ^>=4.14.3.0 + , onomap + , containers + , aeson + , blaze-markup + , servant + , servant-blaze + , servant-server + , http-client + , http-client-tls + , text + , wai + , warp + hs-source-dirs: web default-language: Haskell2010 ghc-options: -O2 -Wall -threaded diff --git a/onomastics-ng/web/Main.hs b/onomastics-ng/web/Main.hs new file mode 100644 index 0000000..b1d3303 --- /dev/null +++ b/onomastics-ng/web/Main.hs @@ -0,0 +1,89 @@ +{-# 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 Data.List (find) +import qualified Data.Map as Map (fromList, mapWithKey) +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 :: ByArea Double} + deriving (Generic) + +instance ToMarkup Response where + toMarkup response = + preEscapedToMarkup $ + renderMap + (color response) + (areas response) + (statistics response) + +instance ToJSON Response where + toJSON response = + toJSON $ + Map.mapWithKey + ( \k double -> + let maybeArea = find ((== k) . key) (areas response) + in Map.fromList + [ ("value" :: Text, toJSON double) + , ("population", toJSON $ fmap population maybeArea) + , ("name", toJSON $ fmap name maybeArea) + ] + ) + (getByArea $ statistics response) + +type OnomapApi = + Capture "mode" Mode + :> Capture "name" Text + :> QueryParam "by" AreaKind + :> QueryParam "color" Text + :> Get '[JSON, HTML] Response + +app :: Manager -> ([Area], [Area]) -> Application +app manager' (theDistricts, theStates) = serve onomapApi server + where + server :: Server OnomapApi + server = \mode surname maybeAreaKind maybeColor -> + 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 + theStatistics <- + computeAreaStatistics computeFunction theAreas <$> case areaMode of + State -> stateStatistics (Just surname) + District -> districtStatistics (Just surname) + return Response{color = fromMaybe "black" maybeColor, areas = theAreas, statistics = theStatistics} + onomapApi :: Proxy OnomapApi + onomapApi = Proxy + +main :: IO () +main = do + manager' <- newTlsManager + runEnv 8081 . app manager' =<< runStoepel manager' (liftM2 (,) districts states)