93 lines
3.1 KiB
Haskell
93 lines
3.1 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-|
|
|
Module : API
|
|
Description : The application API and handlers
|
|
Copyright : (c) Mats Rauhala, 2019
|
|
License : BSD3
|
|
Maintainer : mats.rauhala@iki.fi
|
|
Stability : experimental
|
|
Portability : POSIX
|
|
|
|
Provides the API and handlers for the application.
|
|
|
|
Even if this is only one module, I'm using this same style in all of my projects. Each level of APIs provide their own `API` type and a `handler` who is responsible only for that specific subsection of an API.
|
|
-}
|
|
module API where
|
|
|
|
import Control.Monad.Reader (MonadReader, asks)
|
|
import Control.Monad.Trans (MonadIO)
|
|
import Control.Parallel.Strategies
|
|
import Data.Either (partitionEithers)
|
|
import Data.Foldable (traverse_)
|
|
import Data.List (find, sortOn)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Lucid.Base (HtmlT, ToHtml (..))
|
|
import Lucid.Html5
|
|
import Servant.API
|
|
import Servant.API.Generic
|
|
import Servant.HTML.Lucid
|
|
import Servant.Server.Generic
|
|
|
|
import Data.Caesar
|
|
import Data.Language
|
|
import Solidabis.API (HasClientEnv, HasToken, bullshits,
|
|
getBullshits, message)
|
|
|
|
-- | Data for the frontpage
|
|
--
|
|
-- Our "UI" only cares about the decrypted and non-decryptable sentences
|
|
data Index =
|
|
Index { converted :: [Text]
|
|
, unconverted :: [Text]
|
|
}
|
|
|
|
-- | Wrap a UI within an HTML page
|
|
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
|
|
|
|
-- | Our API type
|
|
--
|
|
-- Consists only of the index route
|
|
newtype API route
|
|
= API { _index :: route :- Get '[HTML] Index }
|
|
deriving Generic
|
|
|
|
-- | API handler
|
|
--
|
|
-- Compares the sentences given by the solidabis api against the model
|
|
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 best
|
|
best = map (findBest languageModel) sentences `using` parListChunk 10 rdeepseq
|
|
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 > -8.1) (reverse ranked)
|
|
in maybe (Left sentence) (Right . snd) found
|