commit ad7290e705323821a275bbf8c0e800b1c4a8fa7b Author: Mats Rauhala Date: Sun Dec 23 23:23:14 2018 +0200 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..849ddff --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist/ diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..8a92c42 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for demobot + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..00aedcc --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..1d6cf74 --- /dev/null +++ b/default.nix @@ -0,0 +1,3 @@ +{ haskellPackages }: + +haskellPackages.callCabal2nix "demobot" ./. {} diff --git a/demobot.cabal b/demobot.cabal new file mode 100644 index 0000000..9ed9be2 --- /dev/null +++ b/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 diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..1fe28e2 --- /dev/null +++ b/release.nix @@ -0,0 +1,21 @@ +{ nixpkgs ? import {} }: + +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; +} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..b3ad7cc --- /dev/null +++ b/shell.nix @@ -0,0 +1,3 @@ +{ nixpkgs ? import {} }: + +(nixpkgs.callPackage ./release.nix {}).shell diff --git a/src/AppM.hs b/src/AppM.hs new file mode 100644 index 0000000..51674ca --- /dev/null +++ b/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 diff --git a/src/Bot/DSL.hs b/src/Bot/DSL.hs new file mode 100644 index 0000000..11294c4 --- /dev/null +++ b/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) diff --git a/src/Bot/DSL/Network.hs b/src/Bot/DSL/Network.hs new file mode 100644 index 0000000..942d38d --- /dev/null +++ b/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 () diff --git a/src/Bot/DSL/State.hs b/src/Bot/DSL/State.hs new file mode 100644 index 0000000..8af702b --- /dev/null +++ b/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 () diff --git a/src/Bot/DSL/Time.hs b/src/Bot/DSL/Time.hs new file mode 100644 index 0000000..b1929c5 --- /dev/null +++ b/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 diff --git a/src/Bot/Extension.hs b/src/Bot/Extension.hs new file mode 100644 index 0000000..e3068f0 --- /dev/null +++ b/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 } diff --git a/src/Bot/Lib.hs b/src/Bot/Lib.hs new file mode 100644 index 0000000..e32b4f0 --- /dev/null +++ b/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 diff --git a/src/Bot/Log.hs b/src/Bot/Log.hs new file mode 100644 index 0000000..e120be1 --- /dev/null +++ b/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 diff --git a/src/Extension/Hello.hs b/src/Extension/Hello.hs new file mode 100644 index 0000000..5a35c98 --- /dev/null +++ b/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 diff --git a/src/Extensions.hs b/src/Extensions.hs new file mode 100644 index 0000000..4b7161f --- /dev/null +++ b/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] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..1c9284d --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import AppM +import Bot.Lib +import Extensions + + +main :: IO () +main = runAppM (mainLoop extensions)