Initial commit

.gitignore

@@ -0,0 +1 @@
+dist/

ChangeLog.md

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

LICENSE

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

Setup.hs

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

default.nix

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

demobot.cabal

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

release.nix

@@ -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;
+}

shell.nix

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

src/AppM.hs

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

src/Bot/DSL.hs

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

src/Bot/DSL/Network.hs

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

src/Bot/DSL/State.hs

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

src/Bot/DSL/Time.hs

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

src/Bot/Extension.hs

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

src/Bot/Lib.hs

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

src/Bot/Log.hs

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

src/Extension/Hello.hs

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

src/Extensions.hs

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

src/Main.hs

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