From 43987f3b0c50e6108e62ba0911a8573633582207 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 15 Oct 2019 22:52:03 +0300 Subject: [PATCH] Basic implementation done --- koodihaaste.cabal | 7 +++++ src/API.hs | 68 ++++++++++++++++++++++++++++++++++++++++ src/Control/Lens.hs | 23 ++++++++++++++ src/Control/Monad/App.hs | 60 +++++++++++++++++++++++++++++++++++ src/Data/Config.hs | 23 ++++++++++++++ src/Data/Language.hs | 8 +++++ src/Main.hs | 17 +++++++++- src/Server.hs | 32 +++++++++++++++++++ src/Solidabis/API.hs | 29 ++++++++++++----- 9 files changed, 259 insertions(+), 8 deletions(-) create mode 100644 src/Control/Lens.hs create mode 100644 src/Control/Monad/App.hs create mode 100644 src/Data/Config.hs diff --git a/koodihaaste.cabal b/koodihaaste.cabal index e4fd07e..2294408 100644 --- a/koodihaaste.cabal +++ b/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 diff --git a/src/API.hs b/src/API.hs index 7d571a7..5fdc94d 100644 --- a/src/API.hs +++ b/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 diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs new file mode 100644 index 0000000..8aac779 --- /dev/null +++ b/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) diff --git a/src/Control/Monad/App.hs b/src/Control/Monad/App.hs new file mode 100644 index 0000000..a2509cb --- /dev/null +++ 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 diff --git a/src/Data/Config.hs b/src/Data/Config.hs new file mode 100644 index 0000000..0a965b8 --- /dev/null +++ b/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 diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 69df3a3..7bb0be5 100644 --- a/src/Data/Language.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 65ae4a0..2dd331e 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Server.hs b/src/Server.hs index d78d913..adb5210 100644 --- a/src/Server.hs +++ b/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 diff --git a/src/Solidabis/API.hs b/src/Solidabis/API.hs index 312a951..2e05ccd 100644 --- a/src/Solidabis/API.hs +++ b/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) - => Token - -> m Bullshit -getBullshits token = _bullshit routes (mkAuthenticatedRequest token authReq) + :: (HasToken r, MonadReader r m, MonadIO m, HasClientEnv r) + => m Bullshit +getBullshits = asks getToken >>= \token -> _bullshit routes (mkAuthenticatedRequest token authReq)