feat(onomastics-ng): add server

2022-04-19 23:11:06 +02:00
parent c766346dfa
commit adfd4238f7
7 changed files with 256 additions and 124 deletions
--- a/onomastics-ng/app/Types.hs
+++ b/onomastics-ng/app/Types.hs
@@ -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
--- a/onomastics-ng/cli/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
--- a/onomastics-ng/lib/Onomap/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
--- a/onomastics-ng/lib/Onomap/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
--- a/onomastics-ng/lib/Onomap/Types.hs
+++ 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
--- 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
--- a/onomastics-ng/web/Main.hs
+++ 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)