diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.2.1 - 04.03.2017 + +- Fixed the templates for the initializer +- added tests to ensure integration test bot and project created by initializer actually compile +- Fixed the travis configurations + # 0.2.0 - 25.02.2017 - Implemented an adapter for IRC diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright JustusAdam (c) 2016 +Copyright JustusAdam (c) 2016, 2017 All rights reserved. diff --git a/initializer/Main.hs b/initializer/Main.hs --- a/initializer/Main.hs +++ b/initializer/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module Main where -import Control.Arrow (second) +import Control.Arrow (second, (***)) import Control.Monad import Data.Foldable (for_) import Data.Maybe (isJust) @@ -44,9 +44,15 @@ ] -adType :: [(String, String)] +adType :: [(String, (String, String))] adType = - [ ("slack-rtm", "SlackRTMAdapter") ] + [ ("slack-rtm", ("Marvin.Adapter.Slack.RTM", "(SlackAdapter RTM)")) + , ("slack-events", ("Marvin.Adapter.Slack.EventsAPI", "(SlackAdapter EventsAPI)")) + , ("telegram-poll", ("Marvin.Adapter.Telegram.Poll", "(TelegramAdapter Poll)")) + , ("telegram-push", ("Marvin.Adapter.Telegram.Push", "(TelegramAdapter Push)")) + , ("shell", ("Marvin.Adapter.Shell", "ShellAdapter")) + , ("irc", ("Marvin.Adapter.IRC", "IRCAdapter")) + ] main :: IO () @@ -55,8 +61,10 @@ d <- ( "initializer") <$> getDataDir unless (isJust $ lookup adapter adType) $ hPutStrLn stderr "Unrecognized adapter" - let subsData = object [ "name" ~> botname - , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " <>) (lookup adapter adType) + let (adModule, adSig) = maybe ("IsAdapter a => ScriptInit a", "") (("import " <>) *** ("ScriptInit " <>)) (lookup adapter adType) + subsData = object [ "name" ~> botname + , "scriptsig" ~> adSig + , "adaptermod" ~> adModule , "adapter" ~> adapter ] diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -1,5 +1,5 @@ name: marvin -version: 0.2.0 +version: 0.2.1 synopsis: A framework for modular, portable chat bots. description: A framework for writing portable chat bots. Inspired by hubot. . @@ -134,19 +134,45 @@ , TupleSections , GADTs --- test-suite slackbot-framework-test --- type: exitcode-stdio-1.0 --- hs-source-dirs: test --- main-is: Spec.hs --- build-depends: base --- , marvin --- ghc-options: -threaded -rtsopts -with-rtsopts=-N --- default-language: Haskell2010 --- default-extensions: OverloadedStrings --- , TypeFamilies --- , MultiParamTypeClasses --- , TupleSections --- , GADTs +test-suite marvin-unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base >= 4.7 && < 5 + , marvin + , hspec >= 2.2 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings + , TypeFamilies + , MultiParamTypeClasses + , TupleSections + , GADTs + +test-suite marvin-integration-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: IntegrationSpec.hs + build-depends: base >= 4.7 && < 5 + , marvin + , hspec >= 2.2 + , temporary >= 1.2 + , process >= 1.2 + , filepath >= 1.4 + , directory >= 1.2 + , monad-loops >= 0.4 + , extra >= 1.4 + , yaml + , lens-aeson + , lens + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings + , TypeFamilies + , MultiParamTypeClasses + , TupleSections + , GADTs source-repository head type: git diff --git a/preprocessor/Main.hs b/preprocessor/Main.hs --- a/preprocessor/Main.hs +++ b/preprocessor/Main.hs @@ -38,6 +38,7 @@ , ("telegram-poll", ("Marvin.Adapter.Telegram.Poll", "(TelegramAdapter Poll)")) , ("telegram-push", ("Marvin.Adapter.Telegram.Push", "(TelegramAdapter Push)")) , ("shell", ("Marvin.Adapter.Shell", "ShellAdapter")) + , ("irc", ("Marvin.Adapter.IRC", "IRCAdapter")) ] diff --git a/resources/initializer/MyScript.hs.mustache b/resources/initializer/MyScript.hs.mustache --- a/resources/initializer/MyScript.hs.mustache +++ b/resources/initializer/MyScript.hs.mustache @@ -2,13 +2,17 @@ import Marvin.Prelude +{{ adaptermod }} +import Control.Monad.Logger -- imported for logging script :: {{ scriptsig }} script = defineScript "my-script" $ do hear (r [CaseInsensitive] "ping") $ do -- react to any message msg <- getMessage -- read the message contents - infoM (content msg) -- logging + $logInfo $(isT "Got message with content: #{msg}") -- logging send "Pong" -- sending messages back respond "hello" $ do -- react to direct commands - reply "Hello to you too" + user <- getUser + username <- getUsername user + reply $(isL "Hello to you too, #{username}") diff --git a/resources/initializer/bot.cabal.mustache b/resources/initializer/bot.cabal.mustache --- a/resources/initializer/bot.cabal.mustache +++ b/resources/initializer/bot.cabal.mustache @@ -9,10 +9,12 @@ executable {{ name }}-bot hs-source-dirs: bot main-is: Main.hs + other-modules: MyScript ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , marvin + , monad-logger default-language: Haskell2010 default-extensions: OverloadedStrings , MultiParamTypeClasses - , NoImplicitPrelude + , TemplateHaskell diff --git a/src/Marvin/Adapter/IRC.hs b/src/Marvin/Adapter/IRC.hs --- a/src/Marvin/Adapter/IRC.hs +++ b/src/Marvin/Adapter/IRC.hs @@ -11,7 +11,7 @@ -} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Rank2Types #-} -module Marvin.Adapter.IRC +module Marvin.Adapter.IRC ( IRCAdapter, IRCChannel ) where @@ -60,6 +60,8 @@ consumer = awaitForever . writeChan +-- NOTE: Maybe we can add some verification of how the server was coping with a message of ours. +-- Perhaps save queries to the server in a queue and associate incoming numerics and such with them? processor :: Chan (Either ByteString IrcEvent) -> EventHandler IRCAdapter -> AdapterM IRCAdapter () processor inChan handler = do IRCAdapter{msgOutChan} <- getAdapter @@ -91,7 +93,6 @@ runHandler = void . async . liftIO . handler - instance IsAdapter IRCAdapter where -- | Stores the username type User IRCAdapter = L.Text @@ -106,12 +107,12 @@ msgType = case chan of Direct n -> Privmsg n RealChannel c -> Notice c - -- | Just returns the value again - getUsername = return + -- TODO Perhaps these resolving funtions should be changed such that + -- they return Nothing if the user doesn't exist. + getUsername = return getChannelName = return . chanName resolveChannel = return . Just . RealChannel - -- | Just returns the value again resolveUser = return . Just initAdapter = IRCAdapter <$> newChan diff --git a/src/Marvin/Util/Mutable.hs b/src/Marvin/Util/Mutable.hs --- a/src/Marvin/Util/Mutable.hs +++ b/src/Marvin/Util/Mutable.hs @@ -49,15 +49,16 @@ -- 'readSynchronized' does not empty it and also blocks if the 'Synchronized' is empty. -- -- Should you just use it as a thread safe mutable variable, mutations typically follow the pattern: +-- -- @ -- val <- takeSynchronized -- obtain the value and leave it empty to block concurrent reads --- let mod = modify val -- modify the value +-- mod <- modifyWithIO val -- modify the value, typically involves IO -- writeSynchronized mod -- write back the result -- @ -- -- Another use for this type is as a message channel, where we have a producer and a consumer, -- the producer tries to write values into the 'Synchronized' ('writeSynchronized') and the consumer --- waits for the 'Synchronized' to be filled and takes the value 'takeSynchronized' for procesing. +-- waits for the 'Synchronized' to be filled and takes the value ('takeSynchronized') for procesing. -- -- It works generally best if any 'Synchronized' is only used for one of these two applications at the same time. -- diff --git a/src/Marvin/Util/Regex.hs b/src/Marvin/Util/Regex.hs --- a/src/Marvin/Util/Regex.hs +++ b/src/Marvin/Util/Regex.hs @@ -25,7 +25,7 @@ instance NFData Regex where rnf (Regex a) = a `seq` () --- Warning: This exposes the underlying repreentation of a 'Regex' and under no curcumstances should be considered stable. +-- Warning: This exposes the underlying representation of a 'Regex' and under no curcumstances should be considered stable. unwrapRegex :: Regex -> Re.Regex unwrapRegex (Regex r) = r diff --git a/test/IntegrationSpec.hs b/test/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/IntegrationSpec.hs @@ -0,0 +1,92 @@ +import Control.Lens +import Control.Monad.Extra +import Data.Aeson.Lens +import Data.Maybe +import Data.Text (Text) +import Data.Yaml +import System.Directory +import System.Environment +import System.FilePath +import System.Info.Extra +import System.IO.Temp +import System.Process +import Test.Hspec + +stackBuildArgs :: [String] +stackBuildArgs + | isMac = ["--extra-lib-dirs=/usr/local/opt/icu4c/lib", "--extra-include-dirs=/usr/local/opt/icu4c/include"] + | otherwise = [] + +copyDirectory :: FilePath -> FilePath -> IO () +copyDirectory source target = do + createDirectoryIfMissing True target + (dirs, files) <- getDirectoryContents source >>= + partitionM (doesDirectoryExist . (source )) + . filter (\a -> not $ a == "." || a == "..") + mapM_ (copyFile <$> (source ) <*> (target )) files + mapM_ (copyDirectory <$> (source ) <*> (target )) dirs + + +-- | In the .travis.yml file I pass the stack yaml as STACK_YAML env variable. +-- This is necessary as the extra-deps are different for some lts versions +-- However the yaml file in STACK_YAML cannot be used by the integration tests, +-- as they require both marvins source directory as well as their own to be +-- recorded in the `packages` key. +-- This function reads the stack.yaml, modifies the `packages` section and +-- writes a new stack.yaml to the target path which the tests pass to stack via +-- then `--stack-yaml` command line parameter +getAndModifyStackYaml :: FilePath -> IO () +getAndModifyStackYaml targetPath = do + path <- fromMaybe "test/resources/stack.yaml" <$> lookupEnv "STACK_YAML" + Just yamlFile <- decodeFile path + encodeFile targetPath $ (yamlFile :: Value) & key "packages" .~ packageObject + where + packageObject = toJSON [".", ".." :: Text] + + +getResolver :: IO String +getResolver = fromMaybe "lts" <$> lookupEnv "STACK_RESOLVER" + + +-- | This test is used to make sure the initializer produces a compileable project +runInitAndCompileResult :: IO () +runInitAndCompileResult = + withTempDirectory "." ".test" $ \dir -> do + getAndModifyStackYaml (dir "stack.yaml") + withCurrentDirectory dir $ do + resolver <- getResolver + callProcess "stack" + [ "exec" + , "--resolver", resolver + , "--stack-yaml", "stack.yaml" + , "--", "marvin-init" + , "-a", "shell" + , "testbot"] + callProcess "stack" $ + [ "build" + , "--stack-yaml", "stack.yaml" + , "--resolver", resolver + ] ++ stackBuildArgs + + +compileIntegration :: IO () +compileIntegration = + withTempDirectory "." ".test" $ \dir -> do + resolver <- getResolver + copyDirectory "test/integration" dir + getAndModifyStackYaml (dir "stack.yaml") + withCurrentDirectory dir $ callProcess "stack" $ + [ "build" + , "--stack-yaml", "stack.yaml" + , "--resolver", resolver + ] ++ stackBuildArgs + + +main :: IO () +main = hspec $ do + describe "the integration test" $ + it "compiles the integration test suite" $ + compileIntegration `shouldReturn` () + describe "initializer" $ + it "produces a compileable project" $ + runInitAndCompileResult `shouldReturn` () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,8 @@ + +import Test.Hspec + +-- TODO add tests. I'm not really sure what to test unfortunately. +-- A lot of the code in this repo is just about interacting with external API's + +main :: IO () +main = hspec $ return ()