Basic implementation done

This commit is contained in:
Mats Rauhala 2019-10-15 22:52:03 +03:00
parent 0b8ccb10e4
commit 43987f3b0c
9 changed files with 259 additions and 8 deletions

View File

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

View File

@ -1 +1,69 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module API where 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

23
src/Control/Lens.hs Normal file
View File

@ -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)

60
src/Control/Monad/App.hs Normal file
View File

@ -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

23
src/Data/Config.hs Normal file
View File

@ -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

View File

@ -14,6 +14,14 @@ data Model
= Model { parts :: Map Text (Sum Int) = Model { parts :: Map Text (Sum Int)
, total :: 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 :: Int
ngram_size = 3 ngram_size = 3

View File

@ -1,4 +1,19 @@
{-# LANGUAGE RecordWildCards #-}
module Main where 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 :: 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

View File

@ -1 +1,33 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Server where 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

View File

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