Initial commit

This commit is contained in:
Mats Rauhala 2018-12-23 23:23:14 +02:00
commit ad7290e705
19 changed files with 281 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
dist/

5
ChangeLog.md Normal file
View File

@ -0,0 +1,5 @@
# Revision history for demobot
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2018, Mats Rauhala
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Mats Rauhala nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

3
default.nix Normal file
View File

@ -0,0 +1,3 @@
{ haskellPackages }:
haskellPackages.callCabal2nix "demobot" ./. {}

51
demobot.cabal Normal file
View File

@ -0,0 +1,51 @@
-- Initial demobot.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: demobot
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD3
license-file: LICENSE
author: Mats Rauhala
maintainer: mats.rauhala@iki.fi
-- copyright:
category: Web
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
library
exposed-modules: Bot.DSL
, Bot.Extension
, Bot.DSL.Network
, Bot.DSL.State
, Bot.DSL.Time
, Bot.Lib
, Bot.Log
-- other-modules:
-- other-extensions:
build-depends: base >=4.11 && <4.12
, text
, mtl
, bytestring
, time
, monad-logger
, exceptions
hs-source-dirs: src
default-language: Haskell2010
executable demobot
main-is: Main.hs
other-modules: Extensions
-- other-extensions:
build-depends: base >=4.11 && <4.12
, demobot
, text
, mtl
, bytestring
, time
, monad-logger
, exceptions
hs-source-dirs: src
default-language: Haskell2010

21
release.nix Normal file
View File

@ -0,0 +1,21 @@
{ nixpkgs ? import <nixpkgs> {} }:
let
demobot = nixpkgs.callPackage ./default.nix {};
shell = nixpkgs.buildEnv {
name = "demobot-shell";
paths = [];
buildInputs = with nixpkgs.haskellPackages; [
ghcid
cabal-install
hasktags
(ghcWithPackages (_: demobot.buildInputs ++ demobot.propagatedBuildInputs))
nixpkgs.binutils-unwrapped
];
};
in
{
inherit demobot shell;
}

3
shell.nix Normal file
View File

@ -0,0 +1,3 @@
{ nixpkgs ? import <nixpkgs> {} }:
(nixpkgs.callPackage ./release.nix {}).shell

33
src/AppM.hs Normal file
View File

@ -0,0 +1,33 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module AppM where
import Bot.DSL
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Logger
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Time as Time
newtype AppM a = AppM (LoggingT IO a)
deriving (Functor, Applicative, Monad, MonadCatch, MonadThrow, MonadLogger, MonadIO)
-- The tagless final interpreter.
instance MonadNetwork AppM where
type Meta AppM = ()
recvMsg = Request <$> liftIO T.getLine <*> pure ()
putMsg Response{..} = liftIO . T.putStrLn $ content
instance MonadData AppM where
putData key val = liftIO $ T.putStrLn $ "Would put " <> T.pack key <> " = " <> (T.pack $ show val)
getData key = liftIO (T.putStrLn $ "Would fetch " <> T.pack key) >> return Nothing
instance MonadTime AppM where
getCurrentTime = liftIO Time.getCurrentTime
runAppM :: AppM a -> IO a
runAppM (AppM f) = runStdoutLoggingT f

18
src/Bot/DSL.hs Normal file
View File

@ -0,0 +1,18 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE Safe #-}
module Bot.DSL
( module Bot.DSL.Network
, module Bot.DSL.State
, module Bot.DSL.Time
, MonadBot
, MonadExtension
) where
import Control.Monad.Logger
import Bot.DSL.Network
import Bot.DSL.State
import Bot.DSL.Time
type MonadBot m = (MonadNetwork m, MonadData m, MonadLogger m, MonadTime m)
type MonadExtension m = (MonadData m, MonadLogger m, MonadTime m)

17
src/Bot/DSL/Network.hs Normal file
View File

@ -0,0 +1,17 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeFamilies #-}
module Bot.DSL.Network where
import Data.Text (Text)
data Request meta = Request { content :: Text
, meta :: meta }
data Response meta = Response { content :: Text
, meta :: meta }
class Monad m => MonadNetwork m where
-- Meta for stuff like event types, or source / target information
type Meta m :: *
recvMsg :: m (Request (Meta m))
putMsg :: Response (Meta m) -> m ()

5
src/Bot/DSL/State.hs Normal file
View File

@ -0,0 +1,5 @@
module Bot.DSL.State where
class Monad m => MonadData m where
getData :: Read a => String -> m (Maybe a)
putData :: Show a => String -> a -> m ()

6
src/Bot/DSL/Time.hs Normal file
View File

@ -0,0 +1,6 @@
module Bot.DSL.Time where
import qualified Data.Time as Time
class Monad m => MonadTime m where
getCurrentTime :: m Time.UTCTime

9
src/Bot/Extension.hs Normal file
View File

@ -0,0 +1,9 @@
{-# Language Safe #-}
{-# Language RankNTypes #-}
{-# Language GADTs #-}
module Bot.Extension where
import Bot.DSL
data Extension meta = Extension { act :: forall m. (meta ~ Meta m, MonadExtension m) => Request meta -> m (Maybe (Response meta))
, name :: String }

29
src/Bot/Lib.hs Normal file
View File

@ -0,0 +1,29 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Bot.Lib where
import Bot.DSL
import Bot.Extension
import Bot.Log
import Control.Monad (forever)
import Control.Monad.Catch (MonadCatch, SomeException, catch, try)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import GHC.Stack
tshow :: Show a => a -> T.Text
tshow = T.pack . show
mainLoop :: forall m. (MonadCatch m, MonadBot m) => [Extension (Meta m)] -> m ()
mainLoop extensions = forever $ catch go handleFail
where
handleFail :: SomeException -> m ()
handleFail e = logError $ tshow e
go :: m ()
go = do
msg <- recvMsg
responses <- catMaybes <$> mapM (\ext -> (act ext) msg) extensions
mapM_ putMsg responses

14
src/Bot/Log.hs Normal file
View File

@ -0,0 +1,14 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Safe #-}
module Bot.Log where
import Control.Monad.Logger (MonadLogger)
import qualified Control.Monad.Logger as Log
import Data.Text (Text)
import GHC.Stack
logInfo :: (HasCallStack, MonadLogger m) => Text -> m ()
logInfo = Log.logInfoCS callStack
logError :: (HasCallStack, MonadLogger m) => Text -> m ()
logError = Log.logErrorCS callStack

15
src/Extension/Hello.hs Normal file
View File

@ -0,0 +1,15 @@
{-# Language RecordWildCards #-}
{-# Language OverloadedStrings #-}
{-# Language ScopedTypeVariables #-}
module Extension.Hello where
import Bot.Extension
import Bot.DSL
import qualified Data.Text as T
extension :: Extension ()
extension = Extension{..}
where
name = "hello world"
act Request{..} | "hello" `T.isPrefixOf` content = return $ Just $ Response "Hello to you" ()
| otherwise = return Nothing

10
src/Extensions.hs Normal file
View File

@ -0,0 +1,10 @@
{-# LANGUAGE Safe #-}
module Extensions where
import Bot.DSL
import Bot.Extension
import qualified Extension.Hello as Hello
extensions :: [Extension ()]
extensions = [Hello.extension]

9
src/Main.hs Normal file
View File

@ -0,0 +1,9 @@
module Main where
import AppM
import Bot.Lib
import Extensions
main :: IO ()
main = runAppM (mainLoop extensions)