packages feed

marvin (empty) → 0.0.1

raw patch · 24 files changed

+1485/−0 lines, 24 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, bytestring, classy-prelude, configurator, directory, filepath, hslogger, lens, mtl, mustache, network-uri, optparse-generic, random, template-haskell, text-format, text-icu, vector, websockets, wreq, wuss

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright JustusAdam (c) 2016++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 JustusAdam 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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ initializer/Main.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveGeneric #-}+module Main where++import ClassyPrelude+import Options.Generic+import Paths_marvin+import System.Directory+import System.FilePath+import Text.Mustache.Compile+import Text.Mustache.Render+import Text.Mustache.Types+++data Opts = Opts +    { botname :: String+    , adapter :: Maybe String+    } deriving (Generic)+++instance ParseRecord Opts+++fromEither :: Show a => Either a b -> b+fromEither (Left e) = error $ "Was left: " ++ show e+fromEither (Right v) = v+++wantDirectories :: [FilePath]+wantDirectories = +    [ "bot" ]+++wantFiles :: [(FilePath, Template)]+wantFiles = map (second $ fromEither . compileTemplate "")+    [ ("Main.hs.mustache", "bot/Main.hs") +    , ("MyScript.hs.mustache", "bot/MyScript.hs")+    , ("config.cfg.mustache", "config.cfg")+    , ("bot.cabal.mustache", "{{name}}.cabal")+    ]+++adType :: [(String, String)]+adType =+    [ ("slack-rtm", "SlackRTMAdapter") ]+++main :: IO ()+main = do+    opts <- getRecord "Marvin init"+    d <- (</> "initializer") <$> getDataDir+    unless ((== Just True) $ (`member` adType) <$> adapter opts) $ putStrLn "Unrecognized adapter"++    let subsData = object [ "name" ~> botname opts+                          , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " ++) (adapter opts >>= flip lookup adType)+                          , "adapter" ~> adapter opts+                          ]++    for_ wantDirectories $ \dir -> do+        exists <- doesDirectoryExist dir+        unless exists (createDirectory dir)++    for_ wantFiles $ \(source, target) -> do+        let targetName = unpack $ substituteValue target subsData+        if ".mustache" == takeExtension source+            then do+                tpl <- fromEither <$> automaticCompile [d] source+                writeFile targetName $ substituteValue tpl subsData +            else copyFile source targetName++    return ()
+ marvin.cabal view
@@ -0,0 +1,118 @@+name:                marvin+version:             0.0.1+synopsis:            A modular bot for slack+description:         Please see README.md+homepage:            https://github.com/JustusAdam/marvin#readme+license:             BSD3+license-file:        LICENSE+author:              JustusAdam+maintainer:          dev@justus.science+copyright:           Copyright: (c) 2016 Justus Adam+category:            Development+build-type:          Simple+extra-source-files:  preprocessor/Main.mustache+data-dir:            resources+data-files:          initializer/*.hs.mustache+                     initializer/config.cfg.mustache+                     initializer/bot.cabal.mustache+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Marvin+                     , Marvin.Prelude+                     , Marvin.Types+                     , Marvin.Run+                     , Marvin.Util.Mutable+                     , Marvin.Util.Regex+                     , Marvin.Util.Random+                     , Marvin.Util.Logging+                     , Marvin.Util.JSON+                     , Marvin.Util.HTTP+                     , Marvin.Adapter+                     , Marvin.Adapter.Slack+  other-modules:       Marvin.Internal+                     , Marvin.Internal.Types+  build-depends:       base >= 4.7 && < 5+                     , classy-prelude+                     , wreq+                     , aeson+                     , mtl+                     , lens+                     , text-icu+                     , vector+                     , optparse-generic+                     , configurator+                     , template-haskell+                     , bytestring+                     , async+                     , hslogger+                     , text-format+                     , websockets+                     , network-uri+                     , wuss+                     , random+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings+                     , TypeFamilies+                     , MultiParamTypeClasses+                     , TupleSections+                     , GADTs+                     , NoImplicitPrelude++executable marvin-pp+  hs-source-dirs:      preprocessor+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , classy-prelude+                     , mustache+                     , directory+                     , filepath+                     , optparse-generic+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings+                     , TypeFamilies+                     , MultiParamTypeClasses+                     , TupleSections+                     , GADTs+                     , NoImplicitPrelude++executable marvin-init+  hs-source-dirs:      initializer+  main-is:             Main.hs+  other-modules:       Paths_marvin+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , classy-prelude+                     , mustache+                     , directory+                     , filepath+                     , optparse-generic+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings+                     , TypeFamilies+                     , MultiParamTypeClasses+                     , TupleSections+                     , GADTs+                     , NoImplicitPrelude++-- test-suite slackbot-framework-test+--   type:                exitcode-stdio-1.0+--   hs-source-dirs:      test+--   main-is:             Spec.hs+--   build-depends:       base+--                      , marvin+--                      , classy-prelude+--   ghc-options:         -threaded -rtsopts -with-rtsopts=-N+--   default-language:    Haskell2010+--   default-extensions:  OverloadedStrings+--                      , TypeFamilies+--                      , MultiParamTypeClasses+--                      , TupleSections+--                      , GADTs+--                      , NoImplicitPrelude++source-repository head+  type:     git+  location: https://github.com/JustusAdam/marvin
+ preprocessor/Main.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+import           ClassyPrelude+import           System.Directory+import           System.FilePath+import           Text.Mustache+import           Text.Mustache.Compile+import Options.Generic+++data Opts = Opts +    { adapter :: Maybe String +    } deriving (Generic)+++instance ParseRecord Opts+++adapters :: [(String, (String, String))]+adapters =+    [("slack-rtm", ("Marvin.Adapter.Slack", "SlackRTMAdapter"))]+++tpl :: Template+tpl = $(embedTemplate ["app"] "Main.mustache")+++main :: IO ()+main = do+    args <- getArgs+    case args of+        (srcname': srcLoc: out:r) -> do+            let opts = getRecordPure r+                srcname = unpack srcname'+                dir = takeDirectory srcname+            paths <- filter (not . ((||) <$> isPrefixOf "_" <*> isPrefixOf ".")) <$> getDirectoryContents dir+            files <- filterM (doesFileExist . (dir </>)) paths+            let hsFiles = map dropExtensions $ filter (/= takeFileName srcname) $ filter ((`elem` [".hs", ".lhs"]) . takeExtension) files+                adapterType = opts >>= adapter >>= flip lookup adapters+                processed = substitute tpl (object [ "scripts" ~> intercalate ", " (map (++ ".script") hsFiles)+                                                    , "imports" ~> hsFiles+                                                    , "adapter-import" ~> map fst adapterType+                                                    , "adapter-type" ~> maybe "AddYourAdapterTypeHere" snd adapterType +                                                    ])+            writeFile (unpack out) processed+        _ -> error "unexpected arguments"
+ preprocessor/Main.mustache view
@@ -0,0 +1,15 @@+import Marvin.Run+import Prelude (IO)+{{# adapter-import }}+import {{ adapter-import }}+{{/ adapter-import }}++{{#imports}}+import qualified {{.}}+{{/imports}}++scripts :: [ScriptInit {{ adapter-type }}]+scripts = [ {{scripts}} ]++main :: IO ()+main = runMarvin scripts
+ resources/initializer/Main.hs.mustache view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF marvin-pp {{# adapter }} -optF --adapter -optF {{ adapter }}{{/adapter}} #-}
+ resources/initializer/MyScript.hs.mustache view
@@ -0,0 +1,14 @@+module MyScript where+++import Marvin.Prelude+++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+        send "Pong" -- sending messages back+    respond "hello" $ do -- react to direct commands+        reply "Hello to you too"
+ resources/initializer/bot.cabal.mustache view
@@ -0,0 +1,18 @@+name:                {{ name }}+version:             0.1+synopsis:            A marvin bot+description:         Please see README.md+category:            Web+build-type:          Simple+cabal-version:       >=1.10++executable {{ name }}-bot+  hs-source-dirs:      bot+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , marvin+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings+                     , MultiParamTypeClasses+                     , NoImplicitPrelude
+ resources/initializer/config.cfg.mustache view
@@ -0,0 +1,10 @@+bot {+    {{# name }}name = "{{ name }}"{{/ name }}+    logging = "DEBUG"+}++adapter {+    {{ adapter }} {+        token = ""+    }+}
+ src/Marvin.hs view
@@ -0,0 +1,31 @@+{-|+Module      : $Header$+Description : Marvin the modular bot+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX++-}+module Marvin+    ( -- * Scripts+      Script, defineScript, ScriptInit+    , ScriptId+    , ScriptDefinition+    , IsAdapter+      -- * Reacting+    , hear, respond, send, reply, messageRoom+    , getMessage, getMatch+    , Message(..), User(..), Room(..)+    , getConfigVal, requireConfigVal+    , BotReacting, HasMessage, HasMatch+    , MessageReactionData, messageField, matchField+    -- ** Advanced actions+    , extractAction, extractReaction+    ) where+++import           Marvin.Adapter  (IsAdapter)+import           Marvin.Internal+import           Marvin.Types
+ src/Marvin/Adapter.hs view
@@ -0,0 +1,57 @@+{-|+Module      : $Header$+Description : The adapter interface+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+{-# LANGUAGE ExplicitForAll      #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Marvin.Adapter where++import           ClassyPrelude+import qualified Data.Configurator.Types as C+import           Marvin.Internal.Types+import qualified System.Log.Logger       as L++data Event+    = MessageEvent Message+++type EventHandler a = Event -> IO ()+type InitEventHandler a = a -> IO (EventHandler a)+++class IsAdapter a where+    adapterId :: AdapterId a+    messageRoom :: a -> Room -> Text -> IO ()+    getUserInfo :: a -> User -> IO (Maybe UserInfo)+    runWithAdapter :: RunWithAdapter a+++type RunWithAdapter a = C.Config -> InitEventHandler a -> IO ()++++adapterLog :: forall m a. (MonadIO m, IsAdapter a) => (String -> String -> IO ()) -> a -> Text -> m ()+adapterLog inner _ message =+    liftIO $ inner (unpack $ "adapter." ++ aid) (unpack message)+  where (AdapterId aid) = adapterId :: AdapterId a+++debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsAdapter a) => a -> Text -> m ()+debugM = adapterLog L.debugM+infoM = adapterLog L.infoM+noticeM = adapterLog L.noticeM+warningM = adapterLog L.warningM+errorM = adapterLog L.errorM+criticalM = adapterLog L.criticalM+alertM = adapterLog L.alertM+emergencyM = adapterLog L.emergencyM+++logM :: (MonadIO m, IsAdapter a) => L.Priority -> a -> Text -> m ()+logM prio = adapterLog (`L.logM` prio)
+ src/Marvin/Adapter/Slack.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE TemplateHaskell #-}+module Marvin.Adapter.Slack (SlackRTMAdapter) where++import           ClassyPrelude+import           Control.Lens               hiding ((.=))+import           Data.Aeson                 hiding (Error)+import           Data.Aeson.TH+import           Data.Aeson.Types           hiding (Error)+import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.Configurator          as C+import qualified Data.Configurator.Types    as C+import           Marvin.Adapter+import           Marvin.Types+import           Network.URI+import           Network.WebSockets+import           Network.Wreq+import           Wuss+++data InternalType+    = Error+        { code :: Int+        , msg  :: Text+        }+    | Unhandeled Text+    | Ignored+++instance FromJSON URI where+    parseJSON (String t) = maybe mzero return $ parseURI $ unpack t+    parseJSON _ = mzero+++instance ToJSON URI where+    toJSON = toJSON . show++++-- data BotData = BotData+--     { botId :: Text+--     , notName :: Text+--     , botCreated :: UTCTime+--     }++-- {+--     "ok": true,+--     "url": "wss:\/\/ms9.slack-msgs.com\/websocket\/7I5yBpcvk",++--     "self": {+--         "id": "U023BECGF",+--         "name": "bobby",+--         "prefs": {+--             …+--         },+--         "created": 1402463766,+--         "manual_presence": "active"+--     },+--     "team": {+--         "id": "T024BE7LD",+--         "name": "Example Team",+--         "email_domain": "",+--         "domain": "example",+--         "icon": {+--             …+--         },+--         "msg_edit_window_mins": -1,+--         "over_storage_limit": false+--         "prefs": {+--             …+--         },+--         "plan": "std"+--     },+--     "users": [ … ],++--     "channels": [ … ],+--     "groups": [ … ],+--     "mpims": [ … ],+--     "ims": [ … ],++--     "bots": [ … ],+-- }+data RTMData = RTMData+    { ok  :: Bool+    , url :: URI+    -- , self :: BotData+    }++data APIResponse a = APIResponse+    { responseOk :: Bool+    , payload    :: a+    }+++deriveJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } ''RTMData+++eventParser :: Value -> Parser (Either InternalType Event)+eventParser (Object o) = isErrParser <|> hasTypeParser+  where+    isErrParser = do+        e <- o .: "error"+        case e of+            (Object eo) -> do+                ev <- Error <$> eo .: "code" <*> eo .: "msg"+                return $ Left ev+            _ -> mzero+    hasTypeParser = do+        t <- o .: "type"++        case t of+            "error" -> do+                ev <- Error <$> o .: "code" <*> o .: "msg"+                return $ Left ev+            "message" -> do+                ev <- Message+                        <$> o .: "user"+                        <*> o .: "channel"+                        <*> o .: "text"+                        <*> o .: "ts"+                return $ Right (MessageEvent ev)+            "reconnect_url" -> return $ Left Ignored+            _ -> return $ Left $ Unhandeled t+eventParser _ = mzero+++rawBS :: BS.ByteString -> Text+rawBS bs = "\"" ++ toStrict (decodeUtf8 bs) ++ "\""+++showt :: Show a => a -> Text+showt = pack . show+++helloParser :: Value -> Parser Bool+helloParser (Object o) = do+    t <- o .: "type"+    return $ (t :: Text) == "hello"+helloParser _ = mzero+++userInfoParser :: Value -> Parser UserInfo+userInfoParser (Object o) = do+    usr <- o .: "user"+    case usr of+        (Object o) -> UserInfo <$> o .: "name" <*> o .: "id"+        _ -> mzero+userInfoParser _ = mzero+++apiResponseParser :: (Value -> Parser a) -> Value -> Parser (APIResponse a)+apiResponseParser f v@(Object o) = APIResponse <$> o .: "ok" <*> f v+apiResponseParser _ _ = mzero+++runConnectionLoop :: C.Config -> MVar BS.ByteString -> MVar Connection -> IO ()+runConnectionLoop cfg messageChan connTracker = forever $ do+    token <- C.require cfg "token"+    debugM pa "initializing socket"+    r <- post "https://slack.com/api/rtm.start" [ "token" := (token :: Text) ]+    case eitherDecode (r^.responseBody) of+        Left err -> errorM pa $ "Error decoding rtm json: " ++ pack err+        Right js -> do+            let uri = url js+                authority = fromMaybe (error "URI lacks authority") (uriAuthority uri)+                host = uriUserInfo authority ++ uriRegName authority+                path = uriPath uri+                portOnErr v = do+                    debugM pa $ "Unreadable port '" ++ pack v ++ "'"+                    return 443+            port <- case uriPort authority of+                        v@(':':r) -> maybe (portOnErr v) return $ readMay r+                        v -> portOnErr v+            debugM pa $ "connecting to socket '" ++ showt uri ++ "'"+            catch+                (runSecureClient host port path $ \conn -> do+                    debugM pa "Connection established"+                    d <- receiveData conn+                    case eitherDecode d >>= parseEither helloParser of+                        Right True -> debugM pa "Recieved hello packet"+                        Left _ -> error $ "Hello packet not readable: " ++ BS.unpack d+                        _ -> error $ "First packet was not hello packet: " ++ BS.unpack d+                    putMVar connTracker conn+                    forever $ do+                        d <- receiveData conn+                        putMVar messageChan d)+                $ \e -> do+                    void $ takeMVar connTracker+                    errorM pa (pack $ show (e :: ConnectionException))+  where+    pa = error "Phantom value" :: SlackRTMAdapter+++runHandlerLoop :: SlackRTMAdapter -> MVar BS.ByteString -> EventHandler SlackRTMAdapter -> IO ()+runHandlerLoop adapter messageChan handler =+    forever $ do+        d <- takeMVar messageChan+        case eitherDecode d >>= parseEither eventParser of+            Left err -> errorM adapter $ "Error parsing json: " ++ pack err ++ " original data: " ++ rawBS d+            Right v ->+                case v of+                    Right event -> handler event+                    Left internalEvent ->+                        case internalEvent of+                            Unhandeled type_ ->+                                debugM adapter $ "Unhandeled event type " ++ type_ ++ " payload " ++ rawBS d+                            Error code msg ->+                                errorM adapter $ "Error from remote code: " ++ showt code ++ " msg: " ++ msg+                            Ignored -> return ()+++runnerImpl :: RunWithAdapter SlackRTMAdapter+runnerImpl cfg handlerInit = do+    midTracker <- newMVar 0+    connTracker <- newEmptyMVar+    messageChan <- newEmptyMVar+    let send d = do+            conn <- readMVar connTracker+            sendTextData conn d+        adapter = SlackRTMAdapter send cfg midTracker+    handler <- handlerInit adapter+    void $ async $ runConnectionLoop cfg messageChan connTracker+    runHandlerLoop adapter messageChan handler+++execAPIMethod :: (Value -> Parser a) -> SlackRTMAdapter -> String -> [FormParam] -> IO (Either String (APIResponse a))+execAPIMethod innerParser adapter method params = do+    token <- C.require cfg "token"+    response <- post ("https://slack.com/api/" ++ method) (("token" := (token :: Text)):params)+    debugM adapter (toStrict $ decodeUtf8 $ response^.responseBody)+    return $ eitherDecode (response^.responseBody) >>= parseEither (apiResponseParser innerParser)+  where+    cfg = userConfig adapter+++newMid :: SlackRTMAdapter -> IO Int+newMid SlackRTMAdapter{midTracker} = do+    id <- takeMVar midTracker+    putMVar midTracker  (id + 1)+    return id+++messageRoomImpl :: SlackRTMAdapter -> Room -> Text -> IO ()+messageRoomImpl adapter (Room room) msg = do+    mid <- newMid adapter+    sendMessage adapter $ encode $+        object [ "id" .= mid+                , "type" .= ("message" :: Text)+                , "channel" .= room+                , "text" .= msg+                ]+++getUserInfoImpl :: SlackRTMAdapter -> User -> IO (Maybe UserInfo)+getUserInfoImpl adapter (User user) = do+    usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user]+    case usr of+        Left err -> errorM adapter ("Parse error when getting user data " ++ pack err) >> return Nothing+        Right (APIResponse True v) -> return (Just v)+        Right (APIResponse False _) -> errorM adapter "Server denied getting user info request" >> return Nothing+++data SlackRTMAdapter = SlackRTMAdapter+    { sendMessage :: BS.ByteString -> IO ()+    , userConfig  :: C.Config+    , midTracker  :: MVar Int+    }+++instance IsAdapter SlackRTMAdapter where+    adapterId = "slack-rtm"+    messageRoom = messageRoomImpl+    getUserInfo = getUserInfoImpl+    runWithAdapter = runnerImpl
+ src/Marvin/Internal.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE ExplicitForAll             #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE UndecidableInstances       #-}+module Marvin.Internal where+++import           ClassyPrelude+import           Control.Monad.State+import qualified Data.Configurator       as C+import qualified Data.Configurator.Types as C++import           Control.Lens            hiding (cons)+import           Marvin.Adapter          (IsAdapter)+import qualified Marvin.Adapter          as A+import           Marvin.Internal.Types+import           Marvin.Util.Logging+import           Marvin.Util.Regex       (Match, Regex)++++declareFields [d|+    data BotActionState a d = BotActionState+        { botActionStateScriptId :: ScriptId+        , botActionStateConfig   :: C.Config+        , botActionStateAdapter :: a+        , botActionStateVariable :: d+        }+    |]++-- | Payload in the reaction Monad when triggered by a message.+--  Contains a field for the 'Message' and a field for the 'Match' from the 'Regex'.+--+-- Both fields are accessible directly via the 'getMessage' and 'getMatch' functions+-- or this data via 'getData'.+declareFields [d|+    data MessageReactionData = MessageReactionData+        { messageReactionDataMessageField :: Message+        , messageReactionDataMatchField :: Match+        }+    |]+++data ActionData d where+    Hear :: Regex -> ActionData MessageReactionData+    Respond :: Regex -> ActionData MessageReactionData+++data WrappedAction a = forall d. WrappedAction (ActionData d) (BotReacting a d ())+++-- | Monad for reacting in the bot. Allows use of functions like 'send', 'reply' and 'messageRoom' as well as any arbitrary 'IO' action.+--+-- The type parameter @d@ is the accessible data provided by the trigger for this action.+-- For message handlers like 'hear' and 'respond' this would be a regex 'Match' and a 'Message' for instance.+newtype BotReacting a d r = BotReacting { runReaction :: StateT (BotActionState a d) IO r } deriving (Monad, MonadIO, Applicative, Functor)++-- | An abstract type describing a marvin script.+--+-- This is basically a collection of event handlers.+declareFields [d|+    data Script a = Script+        { scriptActions   :: [WrappedAction a]+        , scriptScriptId  :: ScriptId+        , scriptConfig    :: C.Config+        , scriptAdapter :: a+        }+    |]+++-- | A monad for gradually defining a 'Script' using 'respond' and 'hear' as well as any 'IO' action.+newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) IO r } deriving (Monad, MonadIO, Applicative, Functor)+++-- | Initializer for a script. This gets run by the server during startup and creates a 'Script'+newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> IO (Script a))+++-- | Class which says that there is a way to get to a 'Message' from this type @m@.+class HasMessage m where+    message :: Lens' m Message++instance HasMessageField m Message => HasMessage m where+    message = messageField++-- | Class which says that there is a way to get to a 'Match' from this type @m@.+class HasMatch m where+    match :: Lens' m Match++instance HasMatchField m Match => HasMatch m where+    match = matchField++instance HasConfigAccess (ScriptDefinition a) where+    getConfigInternal = ScriptDefinition $ use config++instance HasConfigAccess (BotReacting a b) where+    getConfigInternal = BotReacting $ use config++instance IsScript (ScriptDefinition a) where+    getScriptId = ScriptDefinition $ use scriptId++instance IsScript (BotReacting a b) where+    getScriptId = BotReacting $ use scriptId++getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config+getSubConfFor (ScriptId name) = C.subconfig ("script." ++ name) <$> getConfigInternal+++getConfig :: HasConfigAccess m => m C.Config+getConfig = getScriptId >>= getSubConfFor+++addReaction :: ActionData d -> BotReacting a d () -> ScriptDefinition a ()+addReaction data_ action = ScriptDefinition $ actions %= cons (WrappedAction data_ action)+++-- | Whenever any message matches the provided regex this handler gets run.+--+-- Equivalent to "robot.hear" in hubot+hear :: Regex -> BotReacting a MessageReactionData () -> ScriptDefinition a ()+hear !re = addReaction (Hear re)+++-- | Runs the handler only if the bot was directly addressed.+--+-- Equivalent to "robot.respond" in hubot+respond :: Regex -> BotReacting a MessageReactionData () -> ScriptDefinition a ()+respond !re = addReaction (Respond re)+++-- | Send a message to the channel the triggering message came from.+--+-- Equivalent to "robot.send" in hubot+send :: (IsAdapter a, HasMessage m) => Text -> BotReacting a m ()+send msg = do+    o <- getMessage+    messageRoom (channel o) msg+++getUserInfo :: IsAdapter a => User -> BotReacting a m (Maybe UserInfo)+getUserInfo u = do+    a <- BotReacting $ use adapter+    liftIO $ A.getUserInfo a u+++-- | Send a message to the channel the original message came from and address the user that sent the original message.+--+-- Equivalent to "robot.reply" in hubot+reply :: (IsAdapter a, HasMessage m) => Text -> BotReacting a m ()+reply msg = do+    om <- getMessage+    user <- getUserInfo $ sender om+    case user of+        Nothing -> errorM "Message sender has no info, message was not sent"+        Just user -> send $ username user ++ " " ++ msg+++-- | Send a message to a room+messageRoom :: IsAdapter a => Room -> Text -> BotReacting a s ()+messageRoom room msg = do+    a <- BotReacting $ use adapter+    liftIO $ A.messageRoom a room msg+++    -- token <- requireAppConfigVal "token"+    -- liftIO $ async $ post "https://slack.com/api/chat.postMessage"+    --                     [ "token" := (token :: Text)+    --                     , "channel" := roomname room+    --                     , "text" := msg+    --                     ]+    -- return ()+++-- | Define a new script for marvin+--+-- You need to provide a ScriptId (which can simple be written as a non-empty string).+-- This id is used as the key for the section in the bot config belonging to this script and in logging output.+--+-- Roughly equivalent to "module.exports" in hubot.+defineScript :: ScriptId -> ScriptDefinition a () -> ScriptInit a+defineScript sid definitions =+    ScriptInit (sid, runDefinitions sid definitions)+++runDefinitions :: ScriptId -> ScriptDefinition a () -> a -> C.Config -> IO (Script a)+runDefinitions sid definitions ada cfg = execStateT (runScript definitions) (Script mempty sid cfg ada)+++-- | Obtain the reaction dependent data from the bot.+getData :: BotReacting a d d+getData = BotReacting $ use variable+++-- | Get the results from matching the regular expression.+--+-- Equivalent to "msg.match" in hubot.+getMatch :: HasMatch m => BotReacting a m Match+getMatch = BotReacting $ use (variable . match)+++-- | Get the message that triggered this action+-- Includes sender, target channel, as well as the full, untruncated text of the original message+getMessage :: HasMessage m => BotReacting a m Message+getMessage = BotReacting $ use (variable . message)+++-- | Get a value out of the config, returns 'Nothing' if the value didn't exist.+--+-- This config is the config for this script. Ergo all config vars registered under the config section for the ScriptId of this script.+--+-- The 'HasConfigAccess' Constraint means this function can be used both during script definition and when a handler is run.+getConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a)+getConfigVal name = do+    cfg <- getConfig+    liftIO $ C.lookup cfg name+++-- | Get a value out of the config and fail with an error if the specified key is not found.+--+-- This config is the config for this script. Ergo all config vars registered under the config section for the ScriptId of this script.+--+-- The 'HasConfigAccess' Constraint means this function can be used both during script definition and when a handler is run.+requireConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a+requireConfigVal name = do+    cfg <- getConfig+    liftIO $ C.require cfg name+++getAppConfig :: HasConfigAccess m => m C.Config+getAppConfig = getSubConfFor applicationScriptId+++getAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a)+getAppConfigVal name = do+    cfg <- getAppConfig+    liftIO $ C.lookup cfg name+++requireAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a+requireAppConfigVal name = do+    cfg <- getAppConfig+    liftIO $ C.require cfg name+++extractReaction :: BotReacting a s o -> BotReacting a s (IO o)+extractReaction reac = BotReacting $ do+    s <- get+    return $ evalStateT (runReaction reac) s+++extractAction :: BotReacting a () o -> ScriptDefinition a (IO o)+extractAction ac = ScriptDefinition $ do+    a <- use adapter+    sid <- use scriptId+    cfg <- use config+    return $ evalStateT (runReaction ac) (BotActionState sid cfg a ())
+ src/Marvin/Internal/Types.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}+module Marvin.Internal.Types where+++import           ClassyPrelude+import           Control.Lens+import           Data.Aeson+import           Data.Aeson.TH+import           Data.Char               (isAlphaNum, isLetter)+import qualified Data.Configurator.Types as C+import qualified System.Log.Logger       as L+++newtype User = User Text deriving (IsString, Eq)+newtype Room = Room Text deriving (IsString, Eq, Show)+++deriveJSON defaultOptions { unwrapUnaryRecords = True } ''User+deriveJSON defaultOptions { unwrapUnaryRecords = True } ''Room+++data UserInfo = UserInfo+    { username :: Text+    , userID   :: User+    }+++newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show+++data Message = Message+    { sender    :: User+    , channel   :: Room+    , content   :: Text+    , timestamp :: TimeStamp+    }+++instance FromJSON TimeStamp where+    parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMay s+    parseJSON _ = mzero++instance ToJSON TimeStamp where+    toJSON = toJSON . show . unwrapTimeStamp+++-- | A type, basically a String, which identifies a script to the config and the logging facilities.+newtype ScriptId = ScriptId { unwrapScriptId :: Text } deriving (Show, Eq)+++-- | A type, basically a String, which identifies an adapter to the config and the logging facilities.+newtype AdapterId a = AdapterId { unwrapAdapterId :: Text } deriving (Show, Eq)+++applicationScriptId :: ScriptId+applicationScriptId = ScriptId "bot"+++verifyIdString :: String -> (String -> a) -> String -> a+verifyIdString name _ "" = error $ name ++ " must not be empty"+verifyIdString name f s@(x:xs)+    | isLetter x && all (\c -> isAlphaNum c || c == '-' || c == '_' ) xs = f s+    | otherwise = error $ "first character of " ++ name ++ " must be a letter, all other characters can be alphanumeric, '-' or '_'"+++instance IsString ScriptId where+    fromString = verifyIdString "script id" (ScriptId . fromString)+++instance IsString (AdapterId a) where+    fromString = verifyIdString "adapter id" (AdapterId . fromString)+++class HasScriptId s a | s -> a where+    scriptId :: Lens' s a+++-- | Denotes a place from which we may access the configuration.+--+-- During script definition or when handling a request we can obtain the config with 'getConfigVal' or 'requireConfigVal'.+class (IsScript m, MonadIO m) => HasConfigAccess m where+    getConfigInternal :: m C.Config+++class IsScript m where+    getScriptId :: m ScriptId+++prioMapping :: [(Text, L.Priority)]+prioMapping = map ((pack . show) &&& id) [L.DEBUG, L.INFO, L.NOTICE, L.WARNING, L.ERROR, L.CRITICAL, L.ALERT, L.EMERGENCY]+++instance C.Configured L.Priority where+    convert (C.String s) = lookup (toUpper s) prioMapping+    convert _ = Nothing+
+ src/Marvin/Prelude.hs view
@@ -0,0 +1,39 @@+{-|+Module      : $Header$+Description : A collection of all modules useful for using marvin.+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+module Marvin.Prelude+    (+    -- | For exposing parameterised and generalised versions of prelude functions+    module ClassyPrelude+    -- | Marvin :3+    --+    -- Common functions and Types for scripts+    , module Marvin+    -- | Mutable references in marvin scripts+    , module Marvin.Util.Mutable+    -- | Logging in Scripts+    , module Marvin.Util.Logging+    -- | Random numbers and convenience functions+    , module Marvin.Util.Random+    -- | Marvins regex type and how to work with it+    , module Marvin.Util.Regex+    -- | Dealing with JSON+    , module Marvin.Util.JSON+    -- | Format strings which resolve to efficient Strings, aka 'Text'+    , module Data.Text.Format+    ) where++import           ClassyPrelude+import           Data.Text.Format    (format)+import           Marvin+import           Marvin.Util.JSON+import           Marvin.Util.Logging+import           Marvin.Util.Mutable+import           Marvin.Util.Random+import           Marvin.Util.Regex
+ src/Marvin/Run.hs view
@@ -0,0 +1,170 @@+{-|+Module      : $Header$+Description : Running marvin.+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE ExplicitForAll         #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TemplateHaskell        #-}+module Marvin.Run+    ( runMarvin, ScriptInit, IsAdapter+    ) where+++import           ClassyPrelude+import           Control.Concurrent.Async  (wait)+import           Control.Lens              hiding (cons)+import           Control.Monad.State       hiding (mapM_)+import           Data.Char                 (isSpace)+import qualified Data.Configurator         as C+import qualified Data.Configurator.Types   as C+import           Data.Vector               (Vector)+import           Marvin.Adapter+import           Marvin.Internal           hiding (match)+import           Marvin.Internal.Types     hiding (channel)+import           Marvin.Util.Regex+import           Options.Generic+import qualified Prelude                   as P+import qualified System.Log.Formatter      as L+import qualified System.Log.Handler.Simple as L+import qualified System.Log.Logger         as L++++data CmdOptions = CmdOptions+    { configPath :: Maybe FilePath+    , verbose    :: Bool+    , debug      :: Bool+    } deriving (Generic)+++instance ParseRecord CmdOptions+++defaultBotName :: Text+defaultBotName = "marvin"+++requireFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO a+requireFromAppConfig cfg = C.require (C.subconfig (unwrapScriptId applicationScriptId) cfg)+++lookupFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO (Maybe a)+lookupFromAppConfig cfg = C.lookup (C.subconfig (unwrapScriptId applicationScriptId) cfg)+++declareFields [d|+    data Handlers = Handlers+        { handlersResponds :: [(Regex, Message -> Match -> IO ())]+        , handlersHears :: [(Regex, Message -> Match -> IO ())]+        }+    |]+++mkApp :: [Script a] -> C.Config -> a -> EventHandler a+mkApp scripts cfg adapter = handler+  where+    handler (MessageEvent msg) = handleMessage msg++    handleMessage msg = do+        lDispatches <- doIfMatch allListens text+        botname <- fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name"+        let (trimmed, remainder) = splitAt (length botname) $ dropWhile isSpace text+        rDispatches <- if toLower trimmed == toLower botname+                            then doIfMatch allReactions remainder+                            else return mempty+        mapM_ wait (lDispatches ++ rDispatches)+      where+        text = content msg+        doIfMatch things toMatch  =+            catMaybes <$> for things (\(trigger, action) ->+                case match trigger toMatch of+                        Nothing -> return Nothing+                        Just m -> Just <$> async (action msg m))++    flattenActions = foldr $ \script -> flip (foldr (addAction script adapter)) (script^.actions)++    allActions = flattenActions (Handlers mempty mempty) scripts++    allReactions :: Vector (Regex, Message -> Match -> IO ())+    allReactions = fromList $! allActions^.responds+    allListens :: Vector (Regex, Message -> Match -> IO ())+    allListens = fromList $! allActions^.hears+++addAction :: Script a -> a -> WrappedAction a -> Handlers -> Handlers+addAction script adapter wa =+    case wa of+        (WrappedAction (Hear re) ac) -> hears %~ cons (re, runMessageAction script adapter re ac)+        (WrappedAction (Respond re) ac) -> responds %~ cons (re, runMessageAction script adapter re ac)+++runMessageAction :: Script a -> a -> Regex -> BotReacting a MessageReactionData () -> Message -> Match -> IO ()+runMessageAction script adapter re ac msg mtch =+    catch+        (evalStateT (runReaction ac) (BotActionState (script^.scriptId) (script^.config) adapter (MessageReactionData msg mtch)))+        (onScriptExcept (script^.scriptId) re)+++onScriptExcept :: ScriptId -> Regex -> SomeException -> IO ()+onScriptExcept (ScriptId id) r e = do+    err $ "Unhandled exception during execution of script " ++ show id ++ " with trigger " ++ show r+    err $ show e+  where+    err = L.errorM "bot.dispatch"+++-- | Create a wai compliant application+application :: [ScriptInit a] -> C.Config -> InitEventHandler a+application inits config ada = do+    L.infoM "bot" "Initializing scripts"+    s <- catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits+    return $ mkApp s config ada+  where+    onInitExcept :: ScriptId -> SomeException -> IO (Maybe a')+    onInitExcept (ScriptId id) e = do+        err $ "Unhandled exception during initialization of script " ++ show id+        err $ show e+        return Nothing+      where err = L.errorM "bot.init"+++prepareLogger :: IO ()+prepareLogger =+    L.updateGlobalLogger L.rootLoggerName (L.setHandlers [handler])+  where+    handler = L.GenericHandler { L.priority = L.DEBUG+                               , L.formatter = L.simpleLogFormatter "$time [$prio:$loggername] $msg"+                               , L.privData = ()+                               , L.writeFunc = const P.putStrLn+                               , L.closeFunc = const $ return ()+                               }++++runMarvin :: forall a. IsAdapter a => [ScriptInit a] -> IO ()+runMarvin s' = do+    prepareLogger+    args <- getRecord "bot server"+    when (verbose args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.INFO)+    when (debug args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.DEBUG)+    cfgLoc <- maybe+                (L.noticeM "bot" "Using default config: config.cfg" >> return "config.cfg")+                return+                (configPath args)+    (cfg, cfgTid) <- C.autoReload C.autoConfig [C.Required cfgLoc]+    unless (verbose args || debug args) $ C.lookup cfg "bot.logging" >>= maybe (return ()) (L.updateGlobalLogger L.rootLoggerName . L.setLevel)++    runWithAdapter+        (C.subconfig ("adapter." ++ unwrapAdapterId (adapterId :: AdapterId a)) cfg)+        $ application s' cfg+
+ src/Marvin/Types.hs view
@@ -0,0 +1,17 @@+{-|+Module      : $Header$+Description : Common types in marvin.+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+module Marvin.Types+    ( User(..), UserInfo(..), Room(..), Message(..), ScriptId(..)+    , applicationScriptId, IsScript, getScriptId+    , HasConfigAccess+    ) where+++import           Marvin.Internal.Types
+ src/Marvin/Util/HTTP.hs view
@@ -0,0 +1,14 @@+{-|+Module      : $Header$+Description : Performing http/https requests from scripts+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+++-}+module Marvin.Util.HTTP where++
+ src/Marvin/Util/JSON.hs view
@@ -0,0 +1,19 @@+{-|+Module      : $Header$+Description : Working with json in marvin+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX++This is provisionary, this might get properly wrapped at some point.+-}+module Marvin.Util.JSON+    ( module Data.Aeson+    , module Data.Aeson.TH+    ) where+++import           Data.Aeson+import           Data.Aeson.TH
+ src/Marvin/Util/Logging.hs view
@@ -0,0 +1,37 @@+{-|+Module      : $Header$+Description : Logging facilities for marvin scripts.+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+module Marvin.Util.Logging+    ( debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM, logM+    ) where++import           ClassyPrelude+import           Marvin.Types+import qualified System.Log.Logger as L+++scriptLog :: (MonadIO m, IsScript m) => (String -> String -> IO ()) -> Text -> m ()+scriptLog inner message = do+    (ScriptId sid) <- getScriptId+    liftIO $ inner (unpack $ "script." ++ sid) (unpack message)+++debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsScript m) => Text -> m ()+debugM = scriptLog L.debugM+infoM = scriptLog L.infoM+noticeM = scriptLog L.noticeM+warningM = scriptLog L.warningM+errorM = scriptLog L.errorM+criticalM = scriptLog L.criticalM+alertM = scriptLog L.alertM+emergencyM = scriptLog L.emergencyM+++logM :: (MonadIO m, IsScript m) => L.Priority -> Text -> m ()+logM prio = scriptLog (`L.logM` prio)
+ src/Marvin/Util/Mutable.hs view
@@ -0,0 +1,52 @@+{-|+Module      : $Header$+Description : Mutable references for marvin.+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+module Marvin.Util.Mutable where+++import           ClassyPrelude+++-- | A mutable reference to a value of type @v@+type Mutable v = IORef v+++-- | Create a new mutable reference of type @v@ from an initial value.+newMutable :: MonadIO m => a -> m (Mutable a)+newMutable = liftIO . newIORef+++-- | Retrieve the value behind by a mutable reference.+readMutable :: MonadIO m => Mutable a -> m a+readMutable = liftIO . readIORef+++-- | Set the value inside a mutable reference.+writeMutable :: MonadIO m => Mutable a -> a -> m ()+writeMutable m = liftIO . writeIORef m+++-- | Change the value behind a mutable reference.+modifyMutable :: MonadIO m => Mutable a -> (a -> a) -> m ()+modifyMutable m = liftIO . modifyIORef m+++-- type Synchronized = MVar+++-- readSynchronized :: MonadIO m => Synchronized a -> m a+-- readSynchronized = liftIO . readMVar+++-- tryReadSynchronized :: MonadIO m => Synchronized a -> m (Maybe a)+-- tryReadSynchronized = liftIO . tryReadMVar+++-- writeSynchronized :: MonadIO m => Synchronized a -> m ()+-- writeSynchronized
+ src/Marvin/Util/Random.hs view
@@ -0,0 +1,39 @@+{-|+Module      : $Header$+Description : Random numbers and utility functions+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+module Marvin.Util.Random+    ( randomVal, randomValFromRange, randomFrom+    , module System.Random+    ) where+++import           ClassyPrelude+import           System.Random+++-- | Generate a random value. For more information see 'random'+randomVal :: (MonadIO m, Random a) => m a+randomVal = liftIO randomIO+++-- | Generate a random value frbounded by a range. See 'randomR' for how the range works.+randomValFromRange :: (MonadIO m, Random a) => (a, a) -> m a+randomValFromRange = liftIO . randomRIO+++-- | Get a random value out of an integer indexed sequence, like ('Vector', '[a]', 'Seq' or 'Set')+-- This uses the sequences 'length' and therefore does not terminate for infinite sequences.+--+-- Uses the global random number generator.+--+-- Usable in all IO capable monads, such as 'BotReacting' and 'ScriptDefinition'.+randomFrom :: (IsSequence s, Index s ~ Int, MonadIO m) => s -> m (Element s)+randomFrom list = do+  n <- randomValFromRange (0, pred $ length list)+  return $ list `indexEx` n
+ src/Marvin/Util/Regex.hs view
@@ -0,0 +1,52 @@+{-|+Module      : $Header$+Description : Regular expression wrapper for marvin.+Copyright   : (c) Justus Adam, 2016+License     : BSD3+Maintainer  : dev@justus.science+Stability   : experimental+Portability : POSIX+-}+module Marvin.Util.Regex+    ( Regex, Match, r, match, MatchOption(..)+    -- ** Unstable+    , unwrapRegex+    ) where+++import           ClassyPrelude+import           Data.Text.ICU (MatchOption (..))+import qualified Data.Text.ICU as Re+++-- | Abstract Wrapper for a reglar expression implementation. Has an 'IsString' implementation, so literal strings can be used to create a 'Regex'.+-- Alternatively use 'r' to create one with custom options.+newtype Regex = Regex Re.Regex++-- Warning: This exposes the underlying repreentation of a 'Regex' and under no curcumstances should be considered stable.+unwrapRegex :: Regex -> Re.Regex+unwrapRegex (Regex r) = r+++instance Show Regex where+    show = show . unwrapRegex+++-- | A match to a 'Regex'. Index 0 is the full match, all other indexes are match groups.+type Match = [Text]++-- | Compile a regex with options+--+-- Normally it is sufficient to just write the regex as a plain string and have it be converted automatically, but if you want certain match options you can use this function.+r :: [Re.MatchOption] -> Text -> Regex+r opts s = Regex $ Re.regex opts s+++instance IsString Regex where+    fromString "" = error "Empty regex is not permitted, use '.*' or similar instead"+    fromString s = r [] $ pack s+++-- | Match a regex against a string and return the first match found (if any).+match :: Regex -> Text -> Maybe Match+match re = fmap (Re.unfold Re.group) . Re.find (unwrapRegex re)