Basic implementation done

koodihaaste.cabal

@@ -25,6 +25,9 @@ executable koodihaaste
                      , API
                      , Server
                      , Solidabis.API
+                     , Control.Monad.App
+                     , Control.Lens
+                     , Data.Config
   -- other-extensions:
   build-depends:       base >=4.12 && <4.13
                      , servant
@@ -37,5 +40,9 @@ executable koodihaaste
                      , mtl
                      , bytestring
                      , containers
+                     , servant-lucid
+                     , lucid
+                     , warp
+                     , yaml
   hs-source-dirs:      src
   default-language:    Haskell2010

src/API.hs

@@ -1 +1,69 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
 module API where
+
+import           Control.Monad.Reader   (MonadReader, asks)
+import           Control.Monad.Trans    (MonadIO)
+import Data.List (sortOn, find)
+import           Data.Foldable          (traverse_)
+import           Data.Text              (Text)
+import           Lucid.Base             (HtmlT, ToHtml (..))
+import           Lucid.Html5
+import           Servant.API
+import           Servant.API.Generic
+import           Servant.HTML.Lucid
+import           Servant.Server.Generic
+import qualified Data.Text as T
+import Data.Either (partitionEithers)
+import Debug.Trace (traceShow)
+
+import           Solidabis.API          (HasClientEnv, HasToken, bullshits,
+                                         getBullshits, message)
+import Data.Language
+import Data.Caesar
+
+data Index =
+  Index { converted   :: [Text]
+        , unconverted :: [Text]
+        }
+
+page :: Monad m => HtmlT m () -> HtmlT m ()
+page = doctypehtml_ . body_
+
+instance ToHtml Index where
+  toHtml Index{..} = page $ div_ $ do
+    div_ [class_ "decrypted"] $ do
+      h3_ "No bullshit"
+      ul_ $ traverse_ (li_ . toHtml) converted
+    div_ [class_ "bullshit"] $ do
+      h3_ "Bullshit"
+      ul_ $ traverse_ (li_ . toHtml) unconverted
+  toHtmlRaw = toHtml
+
+newtype API route
+  = API { _index :: route :- Get '[HTML] Index }
+  deriving Generic
+
+handler
+  :: (HasModel r, MonadReader r m, HasToken r, HasClientEnv r, MonadIO m)
+  => API (AsServerT m)
+handler =
+  API {
+    _index = do
+      languageModel <- asks getModel
+      sentences <- map message . bullshits <$> getBullshits
+      let (bullshit, noBullshit) = partitionEithers (map (findBest languageModel) sentences)
+      return $ Index noBullshit bullshit
+  }
+  where
+    findBest :: Model -> Text -> Either Text Text
+    findBest model sentence =
+      let caesared = map (\n -> T.map (caesar n) . T.toLower $ sentence) [0..29]
+          ranked = sortOn fst $ [(goodness model x, x) | x <- caesared]
+          found = find (\(rank, _) -> rank > -7.9) (reverse ranked)
+      in ranked `traceShow` maybe (Left sentence) (Right . snd) found

src/Control/Lens.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE RankNTypes #-}
+module Control.Lens where
+
+import           Control.Monad.Reader  (MonadReader, asks)
+import           Data.Functor.Const    (Const (..))
+import           Data.Functor.Identity (Identity (..))
+
+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+
+type Lens' s b = Lens s s b b
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens sa sbt afb s = sbt s <$> afb (sa s)
+
+type Getting r s a = (a -> Const r a) -> s -> Const r s
+
+view :: MonadReader r m => Getting a r a -> m a
+view l = asks (getConst . l Const)
+
+type ASetter s t a b = (a -> Identity b) -> s -> Identity t
+
+set :: ASetter s t a b -> b -> s -> t
+set l b = runIdentity . l (\_ -> Identity b)

src/Control/Monad/App.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes                 #-}
+module Control.Monad.App where
+
+import           Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
+import           Control.Monad.Trans  (MonadIO)
+import           Servant.Client       (BaseUrl, ClientEnv)
+import           Server               (HasPort (..), Port)
+
+import           Control.Lens
+import           Data.Config
+import           Data.Language        (HasModel (..), Model)
+import           Solidabis.API        (HasClientEnv (..), HasToken (..), Token)
+
+
+
+accessToken :: Lens' Config Token
+accessToken = lens _accessToken (\st x -> st{_accessToken=x})
+
+solidabisBase :: Lens' Config BaseUrl
+solidabisBase = lens _solidabisBase (\st x -> st{_solidabisBase=x})
+
+port :: Lens' Config Port
+port = lens _port (\st x -> st{_port = x})
+
+data App
+  = App { _config          :: Config
+        , _solidabisClient :: ClientEnv
+        , _languageModel   :: Model}
+
+config :: Lens' App Config
+config = lens _config (\st x -> st{_config=x})
+
+solidabisClient :: Lens' App ClientEnv
+solidabisClient = lens _solidabisClient (\st x -> st{_solidabisClient=x})
+
+model :: Lens' App Model
+model = lens _languageModel (\st x -> st{_languageModel=x})
+
+instance HasToken App where
+  getToken = view (config . accessToken)
+  setToken app tk = set (config . accessToken) tk app
+
+instance HasClientEnv App where
+  getClientEnv = view solidabisClient
+  setClientEnv app tk = set solidabisClient tk app
+
+instance HasPort App where
+  getPort = view (config . port)
+  setPort app tk = set (config . port) tk app
+
+instance HasModel App where
+  getModel = view model
+  setModel app tk = set model tk app
+
+newtype AppM a = AppM (ReaderT App IO a)
+  deriving (Functor, Applicative, Monad, MonadReader App, MonadIO)
+
+runAppM :: App -> AppM a -> IO a
+runAppM st (AppM f) = runReaderT f st

src/Data/Config.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Data.Config where
+
+import           Server              (Port)
+import           Solidabis.API       (Token)
+
+import           Control.Monad.Trans (MonadIO, liftIO)
+import           Data.Aeson          (FromJSON)
+import           Data.Yaml.Config
+import           GHC.Generics        (Generic)
+import           Servant.Client      (BaseUrl)
+
+data Config
+  = Config { _accessToken   :: Token
+           , _solidabisBase :: BaseUrl
+           , _port          :: Port
+           , _training      :: FilePath }
+  deriving (Show, Generic)
+
+instance FromJSON Config
+
+readConfigFromFile :: MonadIO m => FilePath -> m Config
+readConfigFromFile path = liftIO $ loadYamlSettings [path] [] ignoreEnv

src/Data/Language.hs

@@ -14,6 +14,14 @@ data Model
   = Model { parts :: Map Text (Sum Int)
           , total :: Sum Int }
 
+class HasModel a where
+  getModel :: a -> Model
+  setModel :: a -> Model -> a
+
+instance HasModel Model where
+  getModel = id
+  setModel = const
+
 ngram_size :: Int
 ngram_size = 3
 

src/Main.hs

@@ -1,4 +1,19 @@
+{-# LANGUAGE RecordWildCards #-}
 module Main where
 
+import           Control.Monad.App
+import           Data.Config
+import           Network.HTTP.Client.TLS (newTlsManager)
+import           Servant.Client
+import           Server
+import qualified Data.Text.IO as T
+import Data.Language
+
 main :: IO ()
-main = putStrLn "Hello, Haskell!"
+main = do
+  _config <- readConfigFromFile "config.yaml"
+  manager <- newTlsManager
+  _languageModel <- buildModel <$> T.readFile (_training _config)
+  let state = App{..}
+      _solidabisClient = ClientEnv manager (_solidabisBase _config) Nothing
+  runAppM state server

src/Server.hs

@@ -1 +1,33 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Server where
+
+import           Control.Monad.Reader     (MonadReader, ask, asks, runReaderT)
+import           Control.Monad.Trans      (MonadIO, liftIO)
+import           Data.Aeson               (FromJSON)
+import           Network.Wai.Handler.Warp (run)
+import           Servant
+import           Servant.Server.Generic
+
+import           API                      (handler)
+import           Solidabis.API            (HasClientEnv, HasToken)
+import           Data.Language (HasModel)
+
+newtype Port = Port Int deriving (Show, FromJSON)
+
+class HasPort a where
+  getPort :: a -> Port
+  setPort :: a -> Port -> a
+
+instance HasPort Port where
+  getPort = id
+  setPort = const
+
+app :: (HasModel r, HasClientEnv r, HasToken r) => r -> Application
+app env = genericServeT (`runReaderT` env) API.handler
+
+server
+  :: (HasModel r, HasClientEnv r, HasToken r, HasPort r, MonadReader r m, MonadIO m)
+  => m ()
+server = do
+  Port port <- asks getPort
+  ask >>= liftIO . run port . app

src/Solidabis/API.hs

@@ -4,7 +4,15 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
-module Solidabis.API where
+module Solidabis.API
+  ( getBullshits
+  , Bullshit(..)
+  , Message(..)
+  , HasClientEnv(..)
+  , HasToken(..)
+  , Token
+  )
+  where
 
 import           Control.Exception           (throwIO)
 import           Control.Monad.Reader        (MonadReader, asks)
@@ -36,7 +44,7 @@ newtype API route
 
 class HasClientEnv a where
   getClientEnv :: a -> ClientEnv
-  setClientEnv :: a -> ClientEnv -> ClientEnv
+  setClientEnv :: a -> ClientEnv -> a
 
 instance HasClientEnv ClientEnv where
   getClientEnv = id
@@ -47,7 +55,15 @@ routes = genericClientHoist
   (\x -> asks getClientEnv >>= \env -> liftIO (runClientM x env >>= either throwIO return))
 
 newtype Token = Token String
-  deriving (Semigroup, Monoid, ToHttpApiData, IsString)
+  deriving (Semigroup, Monoid, ToHttpApiData, IsString, Show, FromJSON)
+
+class HasToken a where
+  getToken :: a -> Token
+  setToken :: a -> Token -> a
+
+instance HasToken Token where
+  getToken = id
+  setToken = const
 
 type instance AuthClientData (AuthProtect "jwt") = Token
 
@@ -55,7 +71,6 @@ authReq :: Token -> Request -> Request
 authReq token = Req.addHeader "Authorization" ("Bearer " <> token)
 
 getBullshits
-  :: (MonadReader r m, MonadIO m, HasClientEnv r)
+  :: (HasToken r, MonadReader r m, MonadIO m, HasClientEnv r)
-  => Token
+  => m Bullshit
-  -> m Bullshit
+getBullshits = asks getToken >>= \token -> _bullshit routes (mkAuthenticatedRequest token authReq)
-getBullshits token = _bullshit routes (mkAuthenticatedRequest token authReq)