diff --git a/src/API.hs b/src/API.hs index 2a861b1..7008ae5 100644 --- a/src/API.hs +++ b/src/API.hs @@ -4,6 +4,19 @@ {-# 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) @@ -25,11 +38,15 @@ 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_ @@ -43,10 +60,16 @@ instance ToHtml Index where 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) diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs index 8aac779..439770a 100644 --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -1,23 +1,43 @@ {-# LANGUAGE RankNTypes #-} +{-| +Module : Control.Lens +Description : Simplified functional lenses +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +A very small subset of the lens library reimplemented + +See http://hackage.haskell.org/package/lens for proper docs +-} module Control.Lens where import Control.Monad.Reader (MonadReader, asks) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) +-- | Full lens type type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +-- | Simplified lens type type Lens' s b = Lens s s b b +-- | Build a lens out of a getter and a setter lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) +-- | Getting a value type Getting r s a = (a -> Const r a) -> s -> Const r s +-- | View a value view :: MonadReader r m => Getting a r a -> m a view l = asks (getConst . l Const) +-- | Settering a value type ASetter s t a b = (a -> Identity b) -> s -> Identity t +-- | Set a value 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 index a2509cb..2a6f5b2 100644 --- a/src/Control/Monad/App.hs +++ b/src/Control/Monad/App.hs @@ -1,5 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-| +Module : Control.Monad.App +Description : Our application monad +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +Provides the application monad, which is just a newtype over a ReaderT environment. + +The environment contains the configuration as well as values determind at startup. + +The environment can be thought of as dependency injection. +-} module Control.Monad.App where import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) @@ -14,26 +29,33 @@ import Solidabis.API (HasClientEnv (..), HasToken (..), Token) +-- | Lens for accessing token accessToken :: Lens' Config Token accessToken = lens _accessToken (\st x -> st{_accessToken=x}) +-- | Lens for accessing solidabis base url solidabisBase :: Lens' Config BaseUrl solidabisBase = lens _solidabisBase (\st x -> st{_solidabisBase=x}) +-- | Lens for accessing the server port port :: Lens' Config Port port = lens _port (\st x -> st{_port = x}) +-- | The environment data App = App { _config :: Config , _solidabisClient :: ClientEnv , _languageModel :: Model} +-- | Lens for accessing the config config :: Lens' App Config config = lens _config (\st x -> st{_config=x}) +-- | Lens for accessing the client environment solidabisClient :: Lens' App ClientEnv solidabisClient = lens _solidabisClient (\st x -> st{_solidabisClient=x}) +-- | Lens for accessing the language model model :: Lens' App Model model = lens _languageModel (\st x -> st{_languageModel=x}) @@ -53,8 +75,12 @@ instance HasModel App where getModel = view model setModel app tk = set model tk app +-- | The application monad +-- +-- This is just a 'ReaderT App IO' newtype AppM a = AppM (ReaderT App IO a) deriving (Functor, Applicative, Monad, MonadReader App, MonadIO) +-- | Run the application monad into IO runAppM :: App -> AppM a -> IO a runAppM st (AppM f) = runReaderT f st diff --git a/src/Data/Caesar.hs b/src/Data/Caesar.hs index ce3c37a..d69278e 100644 --- a/src/Data/Caesar.hs +++ b/src/Data/Caesar.hs @@ -1,7 +1,21 @@ +{-| +Module : Data.Caesar +Description : Utilities for doing caesar transforms +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +-} module Data.Caesar where +-- | Type alias over char type Caesar = Char +-- | Translate to the next character on the left +-- +-- Has special handling for some symbols next :: Char -> Char next c = case c of @@ -13,5 +27,6 @@ next c = 'a' -> 'รถ' x -> pred x +-- | Translate a character n times caesar :: Int -> Caesar -> Caesar caesar n x = foldr ($) x (replicate n next) diff --git a/src/Data/Config.hs b/src/Data/Config.hs index 0a965b8..8c6841c 100644 --- a/src/Data/Config.hs +++ b/src/Data/Config.hs @@ -1,4 +1,15 @@ {-# LANGUAGE DeriveGeneric #-} +{-| +Module : Config +Description : Config types +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +The config type with a helper function for reading the config from disk +-} module Data.Config where import Server (Port) @@ -10,6 +21,9 @@ import Data.Yaml.Config import GHC.Generics (Generic) import Servant.Client (BaseUrl) +-- | Config type +-- +-- These are all values that should be known statically beforehand data Config = Config { _accessToken :: Token , _solidabisBase :: BaseUrl @@ -19,5 +33,6 @@ data Config instance FromJSON Config +-- | Read the configuration yaml from file 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 e0a2542..6e4c59c 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,4 +1,17 @@ {-# LANGUAGE RecordWildCards #-} +{-| +Module : Data.Language +Description : The language model +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +An n-gram model over a language. Should be trained with regular text. + +The idea behind this module is to compare a sentence n-grams against the model. Higher the results, higher the probability of it being the same language as the model. +-} module Data.Language where import Data.Foldable (fold) @@ -10,10 +23,12 @@ import Data.Text (Text) import Data.NGram +-- | Model represents the language data Model = Model { parts :: Map Text (Sum Int) , total :: Sum Int } +-- | Has* style pattern for accessing the language model class HasModel a where getModel :: a -> Model setModel :: a -> Model -> a @@ -22,15 +37,20 @@ instance HasModel Model where getModel = id setModel = const +-- | The default n-gram size ngramSize :: Int ngramSize = 3 +-- | Build a language model out of a corpus content buildModel :: Text -> Model buildModel str = let parts = ngram ngramSize str total = fold parts in Model{..} +-- | Calculate the 'goodness' of a sentence +-- +-- Higher numbers means higher probability of being part of the same language as the model goodness :: Model -> Text -> Double goodness Model{..} str = let comparison = M.keys $ ngram ngramSize str diff --git a/src/Data/NGram.hs b/src/Data/NGram.hs index 3c0efe6..9d05b0c 100644 --- a/src/Data/NGram.hs +++ b/src/Data/NGram.hs @@ -1,4 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-| +Module : Data.NGram +Description : N-gram utilities +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +Utilities for building n-gram models +-} module Data.NGram where import Data.List (unfoldr) @@ -8,6 +19,7 @@ import Data.Monoid (Sum (..)) import Data.Text (Text) import qualified Data.Text as T +-- | Build a n-gram frequency map ngram :: Int -> Text -> Map Text (Sum Int) ngram n = M.unionsWith (<>) . unfoldr go where diff --git a/src/Main.hs b/src/Main.hs index 4c61ef0..778bef0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,6 +3,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} +{-| +Module : Main +Description : The main module +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + + +The main access point for the koodihaaste +-} module Main where import Control.Monad.App @@ -14,11 +26,16 @@ import Options.Generic import Servant.Client import Server +-- | The command line endpoint +-- +-- Parses only the path to the config file +-- see config.yaml.sample for the format newtype Cmd = Cmd (FilePath "Config path") deriving Generic instance ParseRecord Cmd +-- | The main function main :: IO () main = do Cmd (Helpful configPath) <- getRecord "koodihaaste" diff --git a/src/Server.hs b/src/Server.hs index a7e2f19..ed90602 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,4 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| +Module : Server +Description : Run the http server +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + + +-} module Server where import Control.Monad.Reader (MonadReader, ask, asks, runReaderT) @@ -12,8 +23,14 @@ import API (handler) import Data.Language (HasModel) import Solidabis.API (HasClientEnv, HasToken) +-- | The port to run on +-- +-- Should be provided within the environment newtype Port = Port Int deriving (Show, FromJSON) +-- | Has* pattern +-- +-- Locate the port within the larger environment structure class HasPort a where getPort :: a -> Port setPort :: a -> Port -> a @@ -22,9 +39,11 @@ instance HasPort Port where getPort = id setPort = const +-- | Convert the servant handler into wai application app :: (HasModel r, HasClientEnv r, HasToken r) => r -> Application app env = genericServeT (`runReaderT` env) API.handler +-- | Run the server server :: (HasModel r, HasClientEnv r, HasToken r, HasPort r, MonadReader r m, MonadIO m) => m () diff --git a/src/Solidabis/API.hs b/src/Solidabis/API.hs index 2e05ccd..d92e1dc 100644 --- a/src/Solidabis/API.hs +++ b/src/Solidabis/API.hs @@ -4,6 +4,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-| +Module : Solidabis.API +Description : The client API for solidabis API +Copyright : (c) Mats Rauhala, 2019 +License : BSD3 +Maintainer : mats.rauhala@iki.fi +Stability : experimental +Portability : POSIX + +Provides the client API for the solidabis API. Implemented through servant generics. +-} module Solidabis.API ( getBullshits , Bullshit(..) @@ -28,9 +39,11 @@ import Servant.Client.Core.Request (Request) import qualified Servant.Client.Core.Request as Req import Servant.Client.Generic +-- | JSON representation of the message layer newtype Message = Message { message :: Text } deriving Generic +-- | JSON representation of the bullshit layer newtype Bullshit = Bullshit { bullshits :: [ Message ] } deriving Generic @@ -42,6 +55,7 @@ newtype API route = API { _bullshit :: route :- AuthProtect "jwt" :> "bullshit" :> Get '[JSON] Bullshit } deriving (Generic) +-- | Has* style pattern for accessing the client environment class HasClientEnv a where getClientEnv :: a -> ClientEnv setClientEnv :: a -> ClientEnv -> a @@ -54,9 +68,11 @@ routes :: (MonadReader r m, MonadIO m, HasClientEnv r) => API (AsClientT m) routes = genericClientHoist (\x -> asks getClientEnv >>= \env -> liftIO (runClientM x env >>= either throwIO return)) +-- | Newtype wrapper over the jwt token newtype Token = Token String deriving (Semigroup, Monoid, ToHttpApiData, IsString, Show, FromJSON) +-- | Has* style pattern for accessing the authentication token class HasToken a where getToken :: a -> Token setToken :: a -> Token -> a @@ -70,6 +86,7 @@ type instance AuthClientData (AuthProtect "jwt") = Token authReq :: Token -> Request -> Request authReq token = Req.addHeader "Authorization" ("Bearer " <> token) +-- | Return the encoded sentences from the solidabis API getBullshits :: (HasToken r, MonadReader r m, MonadIO m, HasClientEnv r) => m Bullshit