Merge pull request #1 from mizunashi-mana/initial-structing

Initial working

README.md

@@ -12,10 +12,22 @@ cd LTSHaskell-slack-bot
 stack install
 ```
 
-## Run
+## Usage
 
 ```bash
-ltshaskell-slackbot --slack-token [Your Slack Token]
+> ltshaskell-slackbot --help
+notification updating of LTSHaskell
+
+Usage: ltshaskell-slackbot [--url|--webhook-url URL] [-t|--delay-time TIME]
+                           [-c|--config FILE] [--snapshots-url URL]
+  LTSHaskell Slack Bot
+
+Available options:
+  -h,--help                Show this help text
+  --url,--webhook-url URL  WebHook URL for Slack Incoming
+  -t,--delay-time TIME     Delay time (seconds)
+  -c,--config FILE         config file
+  --snapshots-url URL      snapshots url
 ```
 
 [travis-image]: https://travis-ci.org/uecmma/LTSHaskell-slack-bot.svg?branch=master

app/Main.hs

@@ -1,6 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
-import Lib
+import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Monad
+import           Data.Maybe             (isNothing)
+import qualified Data.Text              as T
+import           System.Cron
+
+import           Bot.Config
+import           Bot.Message
+import           Bot.Run
+import           Bot.Slack
+
+waiting :: Int -> IO ()
+waiting n = forever $ threadDelay n
 
 main :: IO ()
-main = someFunc
+main = do
+  opts <- getBotOptions
+  url <- T.pack <$> case optsWebhookUrl opts of
+    Just v -> return v
+    _      -> fail "Must be set webhook url"
+  snaps <- getLtsSnapshots_ $ head defaultSnapshotsURLs
+  let stmsnaps = newTVar snaps
+  tids <- execSchedule $
+    addJob (updateSlackCronJob stmsnaps $ sendMsg url) "* * * * *"
+  waiting 1000000
+  where
+    slackConf = SlackConfig
+    slackInfo = SlackPostInfo "haskell" "ltshaskell-bot"
+    slackMessage = SlackMessage ":haskell:"
+
+    sendMsg url info = sendSlackMessage
+      (slackConf url)
+      slackInfo
+      (slackMessage $ defaultMessage info)

ltshaskell-slack-bot.cabal

@@ -15,29 +15,43 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Lib
-                       Bot.Config
+  exposed-modules:     Bot.Config
                        Bot.Types
                        Bot.Run
+                       Bot.Slack
+                       Bot.Message
   build-depends:       base >= 4.7 && < 5
+                     , containers
+                     , unordered-containers
+                     , semigroups
+                     , attoparsec
+                     , safe
                      , aeson
                      , mtl
                      , bytestring
                      , text
+                     , text-show
                      , conduit
                      , http-conduit
                      , monad-logger
                      , path
                      , optparse-applicative
-                     , cron
                      , stm
+                     , time
+                     , safe
+                     , resourcet
+                     , exceptions
   default-language:    Haskell2010
 
 executable ltshaskell-slackbot
   hs-source-dirs:      app
   main-is:             Main.hs
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
+                     , semigroups
+                     , stm
+                     , cron
+                     , text
                      , ltshaskell-slack-bot
   default-language:    Haskell2010
 

src/Bot/Config.hs

@@ -4,9 +4,61 @@ module Bot.Config where
 
 import           Data.Text            (Text)
 import           Network.HTTP.Conduit
+import           Options.Applicative
 
 defaultSnapshotsURLs :: [Text]
 defaultSnapshotsURLs =
   [ "https://www.stackage.org/download/snapshots.json"
   , "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
   ]
+
+data BotOptions = BotOptions
+  { optsWebhookUrl   :: !(Maybe String)
+  , optsDelayTime    :: !(Maybe Int)
+  , optsConfigPath   :: !(Maybe String)
+  , optsSnapshotsUrl :: !(Maybe String)
+  } deriving (Show, Eq)
+
+botOptionsParser :: Parser BotOptions
+botOptionsParser = BotOptions
+  <$> webHookUrlP
+  <*> delayTimeP
+  <*> configPathP
+  <*> snapshotsUrlP
+  where
+    webHookUrlP = optional
+      $  option str
+      $  long "url"
+      <> long "webhook-url"
+      <> help "WebHook URL for Slack Incoming"
+      <> metavar "URL"
+
+    delayTimeP = optional
+      $  option auto
+      $  short 't'
+      <> long "delay-time"
+      <> help "Delay time (seconds)"
+      <> metavar "TIME"
+
+    configPathP = optional
+      $  option str
+      $  short 'c'
+      <> long "config"
+      <> help "config file"
+      <> metavar "FILE"
+
+    snapshotsUrlP = optional
+      $  option str
+      $  long "snapshots-url"
+      <> help "snapshots url"
+      <> metavar "URL"
+
+allBotInfo :: ParserInfo BotOptions
+allBotInfo = info
+  (helper <*> botOptionsParser)
+  $  fullDesc
+  <> progDesc "LTSHaskell Slack Bot"
+  <> header   "notification updating of LTSHaskell"
+
+getBotOptions :: IO BotOptions
+getBotOptions = execParser allBotInfo

src/Bot/Message.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
+
+module Bot.Message where
+
+import           Data.IntMap    (IntMap)
+import qualified Data.IntMap    as IntMap
+import           Data.Semigroup
+import           Data.Text      (Text)
+import qualified Data.Text      as T
+
+import           Bot.Types
+
+data MessageLang
+  = LanguageEnUs
+  | LanguageJaJp
+  deriving (Show, Eq, Ord, Enum)
+
+data MessageTheme
+  = NormalTheme
+  | DetailTheme
+  | PrettyTheme
+  deriving (Show, Eq, Ord, Enum)
+
+data LtsHaskellType
+  = LtsHaskell Int
+  | LatestLtsHaskell
+  | NightlyLtsHaskell
+  deriving (Show, Eq, Ord)
+
+data LtsHaskellUpdateInfo = LtsHaskellUpdateInfo
+  { getLtsHaskellType :: !LtsHaskellType
+  , getBeforeVersion  :: !Text
+  , getAfterVersion   :: !Text
+  , getDetailUrl      :: !Text
+  }
+
+toLatestInfo :: LtsHaskellUpdates -> Maybe LtsHaskellUpdateInfo
+toLatestInfo updates = do
+  info <- getLatestUpdate updates
+  let befver = T.pack . show $ getBeforeLtsVersion info
+  let aftver = T.pack . show $ getAfterLtsVersion info
+  return $ LtsHaskellUpdateInfo
+    LatestLtsHaskell
+    befver aftver
+    $ "https://www.stackage.org/" <> aftver
+
+toNightlyInfo :: LtsHaskellUpdates -> Maybe LtsHaskellUpdateInfo
+toNightlyInfo updates = do
+  info <- getNightlyUpdate updates
+  let befver = "nightly-" <> T.pack (show $ getBeforeNightlyDay info)
+  let aftver = "nightly-" <> T.pack (show $ getAfterNightlyDay info)
+  return $ LtsHaskellUpdateInfo
+    NightlyLtsHaskell
+    befver aftver
+    $ "https://www.stackage.org/" <> aftver
+
+toLtsInfos :: LtsHaskellUpdates -> IntMap LtsHaskellUpdateInfo
+toLtsInfos updates = IntMap.fromList $ do
+  (v, info) <- IntMap.toList $ getEachLtsUpdates updates
+  let befver = T.pack . show $ getBeforeLtsVersion info
+  let aftver = T.pack . show $ getAfterLtsVersion info
+  return . (v,) $ LtsHaskellUpdateInfo
+    (LtsHaskell v)
+    befver aftver
+    $ "https://www.stackage.org/" <> aftver
+
+defaultMessage :: LtsHaskellUpdateInfo -> Text
+defaultMessage LtsHaskellUpdateInfo{..} =
+  "LTS Haskell updated! :tada:   "
+  <> "(" <> getBeforeVersion <> " -> " <> getAfterVersion <> ")\n"
+  <> "For more information, see " <> getDetailUrl

src/Bot/Run.hs

@@ -1 +1,44 @@
-module Bot.Run where
+module Bot.Run
+  ( getLtsSnapshots
+  , getLtsSnapshots_
+  , checkLtsHaskellUpdates
+  , updateSlackCronJob
+  ) where
+
+import           Control.Concurrent.STM
+import           Control.Monad
+import           Control.Monad.Trans
+import           Data.Aeson
+import           Data.Maybe             (fromMaybe)
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import           Network.HTTP.Conduit
+
+import           Bot.Config
+import           Bot.Message
+import           Bot.Types
+
+getLtsSnapshots :: MonadIO m => Text -> m (Maybe Snapshots)
+getLtsSnapshots url = decode <$> simpleHttp (T.unpack url)
+
+getLtsSnapshots_ :: MonadIO m => Text -> m Snapshots
+getLtsSnapshots_ url = do
+  msnaps <- getLtsSnapshots url
+  case msnaps of
+    Just snaps -> return snaps
+    _          -> fail "Failed to get snapshots"
+
+checkLtsHaskellUpdates :: MonadIO m => Snapshots -> m (Snapshots, LtsHaskellUpdates)
+checkLtsHaskellUpdates snaps = do
+  nsnaps <- getLtsSnapshots_ $ head defaultSnapshotsURLs
+  return (nsnaps, checkUpdates snaps nsnaps)
+
+updateSlackCronJob :: MonadIO m => STM (TVar Snapshots) -> (LtsHaskellUpdateInfo -> m ()) -> m ()
+updateSlackCronJob stmsnaps sendMsg = do
+  snaps <- liftIO $ atomically $ stmsnaps >>= readTVar
+  (newsnaps, updates) <- checkLtsHaskellUpdates snaps
+  liftIO $ putStrLn $ "trace: " ++ show newsnaps
+  liftIO $ atomically $ stmsnaps >>= flip writeTVar newsnaps
+  fromMaybe (return ()) $ do
+    info <- toLatestInfo updates
+    return $ liftIO (putStrLn "trace: sending to slack...") >> sendMsg info

src/Bot/Slack.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Bot.Slack
+  ( SlackMessage (..)
+  , SlackPostInfo (..)
+  , SlackPostData (..)
+  , SlackConfig (..)
+  , postToSlack
+  , sendSlackMessage
+  ) where
+
+import           Control.Monad
+import           Control.Monad.Catch
+import           Control.Monad.Trans
+import           Control.Monad.Trans.Resource
+import           Data.Aeson
+import qualified Data.ByteString              as BS
+import qualified Data.ByteString.Lazy         as BSL
+import           Data.Text                    (Text)
+import qualified Data.Text                    as T
+import           Network.HTTP.Conduit
+
+data SlackMessage = SlackMessage
+  { getIcon :: !Text
+  , getText :: !Text
+  } deriving (Show, Eq)
+
+data SlackPostInfo = SlackPostInfo
+  { getChannel  :: !Text
+  , getUserName :: !Text
+  } deriving (Show, Eq)
+
+data SlackPostData = SlackPostData
+  { getInfo    :: !SlackPostInfo
+  , getMessage :: !SlackMessage
+  } deriving (Show, Eq)
+
+instance ToJSON SlackPostData where
+  toJSON SlackPostData{..} = object
+    [ "channel"    .= getChannel getInfo
+    , "username"   .= getUserName getInfo
+    , "text"       .= getText getMessage
+    , "icon_emoji" .= getIcon getMessage
+    ]
+
+data SlackConfig = SlackConfig
+  { webhookUrl :: !Text
+  } deriving (Show, Eq)
+
+getPostRequest ::
+  MonadThrow m => [(BS.ByteString, BS.ByteString)] -> Text -> m Request
+getPostRequest pdata = return . urlEncodedBody pdata <=< parseUrl . T.unpack
+
+postToSlack :: SlackConfig -> SlackPostData -> IO BSL.ByteString
+postToSlack c d = runResourceT $ do
+  req <- getPostRequest
+    [("payload", BSL.toStrict . encode $ d)]
+    $ webhookUrl c
+  manager <- liftIO $ newManager tlsManagerSettings
+  res <- httpLbs req manager
+  return $ responseBody res
+
+sendSlackMessage :: MonadIO m => SlackConfig -> SlackPostInfo -> SlackMessage -> m ()
+sendSlackMessage c i m = void $ liftIO $ postToSlack c $ SlackPostData i m