├── app.cfg
├── .ghci
├── Setup.hs
├── app
    └── Main.hs
├── .gitignore
├── README.md
├── test
    └── Spec.hs
├── stack.yaml
├── LICENSE
├── src
    ├── Types.hs
    ├── Providers
    │   ├── Hoogle.hs
    │   └── Hayoo.hs
    ├── Bot.hs
    └── Utils.hs
└── typebot.cabal


/app.cfg:
--------------------------------------------------------------------------------
1 | token="http://www.slack.com"
2 | 


--------------------------------------------------------------------------------
/.ghci:
--------------------------------------------------------------------------------
1 | :set -XOverloadedStrings
2 | :set -XQuasiQuotes
3 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | 
3 | main = defaultMain
4 | 


--------------------------------------------------------------------------------
/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 | 
3 | import           Bot (runApp)
4 | 
5 | main :: IO ()
6 | main = runApp
7 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | dist*
 2 | *.hi
 3 | *.o
 4 | .hsenv*
 5 | .stack-work/
 6 | .cabal-sandbox
 7 | cabal.sandbox.config
 8 | .DS_Store
 9 | *.swp
10 | *.keter


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # typebot
 2 | 
 3 | A slack bot that will fetch type signatures via Hoogle:
 4 | 
 5 | <img src="http://i.imgur.com/k10Aqrb.png" width="800">
 6 | 
 7 | ## Configuration
 8 | 
 9 | * Create a custom outgoing webhook integration in slack, and save the token.
10 | * Create a custom incoming webook integration in slack, and save the URL.
11 | * Configure the app.cfg as:
12 | 
13 | ```
14 | token="URL"
15 | ```
16 | 
17 | You can have the same bot service multiple slack teams by adding additional
18 | `token="URL"` lines. Deploy to your favorite server/provider.
19 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 2 | module Main (main) where
 3 | 
 4 | import           Test.Hspec
 5 | import           Test.Hspec.Wai
 6 | import           Test.Hspec.Wai.JSON
 7 | import           Data.Aeson (Value(..), object, (.=))
 8 | 
 9 | import           Example (app)
10 | 
11 | main :: IO ()
12 | main = hspec spec
13 | 
14 | spec :: Spec
15 | spec = with app $ do
16 |   describe "GET /" $ do
17 |     it "responds with 200" $ do
18 |       get "/" `shouldRespondWith` 200
19 | 
20 |     it "responds with 'hello'" $ do
21 |       get "/" `shouldRespondWith` "hello"
22 | 
23 |     it "responds with 200 / 'hello'" $ do
24 |       get "/" `shouldRespondWith` "hello" {matchStatus = 200}
25 | 
26 |     it "has 'Content-Type: text/plain; charset=utf-8'" $ do
27 |       get "/" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]}
28 | 
29 |   describe "GET /some-json" $ do
30 |     it "responds with some JSON" $ do
31 |       get "/some-json" `shouldRespondWith` [json|{foo: 23, bar: 42}|]
32 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html
 2 | 
 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
 4 | resolver: lts-5.10
 5 | 
 6 | # Local packages, usually specified by relative directory name
 7 | packages:
 8 | - '.'
 9 | 
10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11 | extra-deps: [html-entities-1.1.0.0]
12 | 
13 | # Override default flag values for local packages and extra-deps
14 | flags: {}
15 | 
16 | # Extra package databases containing global packages
17 | extra-package-dbs: []
18 | 
19 | # Control whether we use the GHC we find on the path
20 | # system-ghc: true
21 | 
22 | # Require a specific version of stack, using version ranges
23 | # require-stack-version: -any # Default
24 | # require-stack-version: >= 1.0.0
25 | 
26 | # Override the architecture used by stack, especially useful on Windows
27 | # arch: i386
28 | # arch: x86_64
29 | 
30 | # Extra directories used by stack for building
31 | # extra-include-dirs: [/path/to/dir]
32 | # extra-lib-dirs: [/path/to/dir]
33 | 
34 | # Allow a newer minor version of GHC than the snapshot specifies
35 | # compiler-check: newer-minor
36 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright Sid Raval (c) 2016
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Sid Raval nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/src/Types.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 3 | 
 4 | module Types where
 5 | 
 6 | import           Control.Monad.IO.Class (MonadIO)
 7 | import           Control.Monad.Reader (MonadReader, ReaderT)
 8 | import           Data.Aeson (Object, FromJSON(parseJSON), withObject, (.:), (.:?))
 9 | import           Data.Aeson.Types (Parser)
10 | import           Data.Configurator.Types
11 | import           Data.Maybe (listToMaybe)
12 | import           Web.Scotty.Trans (ActionT)
13 | import qualified Data.Text.Lazy as L
14 | 
15 | data SearchResult = SearchResult { typeString :: String, locationURL :: String } deriving (Show)
16 | 
17 | instance FromJSON SearchResult where
18 |   parseJSON = withObject "" parseSearchResult
19 | 
20 | parseSearchResult :: Object -> Parser SearchResult
21 | parseSearchResult v = SearchResult <$> v .: "self" <*> v .: "location"
22 | 
23 | newtype ResultList = ResultList [SearchResult] deriving (Show)
24 | 
25 | data SearchEngine = Hayoo | Hoogle deriving (Show)
26 | 
27 | firstResult :: ResultList -> Maybe SearchResult
28 | firstResult (ResultList xs) = listToMaybe xs
29 | 
30 | instance FromJSON ResultList where
31 |   parseJSON = withObject "" parseResultList
32 | 
33 | parseResultList :: Object -> Parser ResultList
34 | parseResultList v = ResultList <$> v .: "results"
35 | 
36 | data AppConfig = AppConfig { appConfig :: Config, appSearchEngine :: SearchEngine }
37 | 
38 | newtype ConfigM a = ConfigM { runConfigM :: ReaderT AppConfig IO a } deriving (Applicative, Functor, Monad, MonadIO, MonadReader AppConfig)
39 | 
40 | type TypeBot a = ActionT L.Text ConfigM a
41 | 


--------------------------------------------------------------------------------
/src/Providers/Hoogle.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 2 | 
 3 | module Providers.Hoogle where
 4 | 
 5 | import           Control.Monad.IO.Class (MonadIO, liftIO)
 6 | import           Data.Aeson (Object, FromJSON(parseJSON), decode, withObject, (.:))
 7 | import           Data.Aeson.Types (Parser)
 8 | import           Data.Maybe (listToMaybe)
 9 | import           Data.Text (Text, unpack)
10 | import           Network.HTTP.Conduit
11 | import           Text.Shakespeare.Text
12 | import           Types
13 | import           Utils (removeCommandChars)
14 | 
15 | data HoogleResult = HoogleResult
16 |   { hoogleType :: String
17 |   , hoogleLocationURL :: String
18 |   } deriving (Show)
19 | 
20 | instance FromJSON HoogleResult where
21 |   parseJSON = withObject "" parseHoogleResult
22 | 
23 | parseHoogleResult :: Object -> Parser HoogleResult
24 | parseHoogleResult v = HoogleResult <$> v .: "self" <*> v .: "location"
25 | 
26 | newtype HoogleResults = HoogleResults [HoogleResult] deriving (Show)
27 | 
28 | instance FromJSON HoogleResults where
29 |   parseJSON = withObject "" parseHoogleResults
30 | 
31 | parseHoogleResults :: Object -> Parser HoogleResults
32 | parseHoogleResults v = HoogleResults <$> v .: "results"
33 | 
34 | firstHoogleResult :: HoogleResults -> Maybe HoogleResult
35 | firstHoogleResult (HoogleResults xs) = listToMaybe xs
36 | 
37 | hoogleUrl :: Text -> String
38 | hoogleUrl x = unpack $ [st|https://www.haskell.org/hoogle/?mode=json&hoogle=#{x}&start=1&count=1|]
39 | 
40 | hoogle :: (MonadIO m) => Text -> m (Maybe SearchResult)
41 | hoogle f = liftIO $ do
42 |   response <- sequence $ simpleHttp . hoogleUrl <$> removeCommandChars f
43 |   return $ translateHoogle <$> (firstHoogleResult =<< decode =<< response)
44 | 
45 | translateHoogle :: HoogleResult -> SearchResult
46 | translateHoogle (HoogleResult ht hlurl) = SearchResult ht hlurl
47 | 


--------------------------------------------------------------------------------
/src/Providers/Hayoo.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 2 | 
 3 | module Providers.Hayoo where
 4 | 
 5 | import           Control.Monad.IO.Class (MonadIO, liftIO)
 6 | import           Data.Aeson (Object, FromJSON(parseJSON), decode, withObject, (.:), (.:?))
 7 | import           Data.Aeson.Types (Parser)
 8 | import           Data.Maybe (listToMaybe)
 9 | import           Data.Text (Text, unpack)
10 | import           Network.HTTP.Conduit
11 | import           Text.Shakespeare.Text
12 | import           Types
13 | import           Utils (removeCommandChars)
14 | 
15 | data HayooResult = HayooResult
16 |   { fname :: String
17 |   , ftype :: Maybe String
18 |   , flocation :: String
19 |   } deriving (Show)
20 | 
21 | instance FromJSON HayooResult where
22 |   parseJSON = withObject "" parseHayooResult
23 | 
24 | parseHayooResult :: Object -> Parser HayooResult
25 | parseHayooResult v = HayooResult <$> v .: "resultName" <*> v .:? "resultSignature" <*> v .: "resultUri"
26 | 
27 | newtype HayooResults = HayooResults [HayooResult] deriving (Show)
28 | 
29 | instance FromJSON HayooResults where
30 |   parseJSON = withObject "" parseHayooResults
31 | 
32 | parseHayooResults :: Object -> Parser HayooResults
33 | parseHayooResults v = HayooResults <$> v .: "result"
34 | 
35 | firstHayooResult :: HayooResults -> Maybe HayooResult
36 | firstHayooResult (HayooResults xs) = listToMaybe xs
37 | 
38 | hayooUrl :: Text -> String
39 | hayooUrl x = unpack $ [st|http://hayoo.fh-wedel.de/json?query=#{x}|]
40 | 
41 | hayoo :: (MonadIO m) => Text -> m (Maybe SearchResult)
42 | hayoo f = liftIO $ do
43 |   response <- sequence $ simpleHttp . hayooUrl <$> removeCommandChars f
44 |   return $ translateHayoo <$> (firstHayooResult =<< decode =<< response)
45 | 
46 | translateHayoo :: HayooResult -> SearchResult
47 | translateHayoo (HayooResult fn (Just ft) fl) = SearchResult (fn ++ " :: " ++ ft) fl
48 | translateHayoo (HayooResult fn _ fl) = SearchResult fn fl
49 | 


--------------------------------------------------------------------------------
/typebot.cabal:
--------------------------------------------------------------------------------
 1 | name:                typebot
 2 | version:             0.1.0.0
 3 | synopsis:            Initial project template from stack
 4 | description:         Please see README.md
 5 | homepage:            http://github.com/sidrava/typebot#readme
 6 | license:             BSD3
 7 | license-file:        LICENSE
 8 | author:              Sid Raval
 9 | maintainer:          sidsraval@gmail.com
10 | copyright:           2016 Author name here
11 | category:            Web
12 | build-type:          Simple
13 | -- extra-source-files:
14 | cabal-version:       >=1.10
15 | 
16 | library
17 |   hs-source-dirs:      src
18 |   exposed-modules:     Bot, Types, Utils, Providers.Hoogle, Providers.Hayoo
19 |   build-depends:       base >= 4.7 && < 5
20 |                      , aeson
21 |                      , scotty
22 |                      , wai
23 |                      , http-types
24 |                      , text
25 |                      , transformers
26 |                      , containers
27 |                      , aeson
28 |                      , http-conduit
29 |                      , network-uri
30 |                      , html-entities
31 |                      , HTTP
32 |                      , mtl
33 |                      , configurator
34 |                      , data-default-class
35 |                      , warp
36 |                      , shakespeare
37 |   default-language:    Haskell2010
38 | 
39 | executable typebot-exe
40 |   hs-source-dirs:      app
41 |   main-is:             Main.hs
42 |   ghc-options:         -threaded -O2 -rtsopts -with-rtsopts=-N -Wall
43 |   build-depends:       base
44 |                      , typebot
45 |   default-language:    Haskell2010
46 | 
47 | test-suite typebot-test
48 |   type:                exitcode-stdio-1.0
49 |   hs-source-dirs:      test
50 |   main-is:             Spec.hs
51 |   build-depends:       base
52 |                      , typebot
53 |                      , hspec
54 |                      , hspec-wai
55 |                      , hspec-wai-json
56 |                      , aeson
57 |   ghc-options:         -threaded -O2 -rtsopts -with-rtsopts=-N
58 |   default-language:    Haskell2010
59 | 
60 | source-repository head
61 |   type:     git
62 |   location: https://github.com/sidrava/typebot
63 | 


--------------------------------------------------------------------------------
/src/Bot.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 2 | 
 3 | module Bot (runApp) where
 4 | 
 5 | import           Control.Monad (void)
 6 | import           Control.Monad.IO.Class (MonadIO, liftIO)
 7 | import           Control.Monad.Reader (asks, lift, runReaderT)
 8 | import           Data.Configurator as C
 9 | import           Data.Configurator.Types (Config)
10 | import           Data.Text (Text, unpack)
11 | import           Data.Text.Lazy.Encoding (encodeUtf8)
12 | import           Network.HTTP.Conduit
13 | import           Network.HTTP.Types.Status (Status(..))
14 | import           Providers.Hayoo
15 | import           Providers.Hoogle
16 | import           Text.Shakespeare.Text
17 | import           Types
18 | import           Utils
19 | import           Web.Scotty.Trans (ScottyT, get, post, scottyOptsT, status)
20 | import qualified Data.Text.Lazy as L
21 | 
22 | runApp :: IO ()
23 | runApp = do
24 |   c <- C.load [Required "app.cfg"]
25 |   s <- engine <$> C.lookup c "engine"
26 |   o <- opts
27 |   scottyOptsT o (runIO c s) app' where
28 |     runIO :: Config -> SearchEngine -> ConfigM a -> IO a
29 |     runIO c s m = runReaderT (runConfigM m) $ AppConfig c s
30 | 
31 | engine :: Maybe Text -> SearchEngine
32 | engine (Just "hayoo") = Hayoo
33 | engine _ = Hoogle
34 | 
35 | app' :: ScottyT L.Text ConfigM ()
36 | app' = do
37 |   get "/" $ status $ Status 200 "OK"
38 |   post "/type" $ authorized $ requireParameter "text" typeRequest
39 | 
40 | typeRequest :: Text -> TypeBot ()
41 | typeRequest f = do
42 |   s <- lift $ asks appSearchEngine
43 |   result <- search s f
44 |   maybe (noResultsSlack f) slackRequest result
45 | 
46 | search :: (MonadIO m) => SearchEngine -> (Text -> m (Maybe SearchResult))
47 | search Hoogle = hoogle
48 | search Hayoo = hayoo
49 | 
50 | humanFriendlyUrl :: SearchEngine -> Text -> String
51 | humanFriendlyUrl Hoogle x = unpack $ [st|https://www.haskell.org/hoogle/?hoogle=#{x}&start=1&count=1|]
52 | humanFriendlyUrl Hayoo x = unpack $ [st|http://hayoo.fh-wedel.de/?query=#{x}|]
53 | 
54 | noResultsSlack :: Text -> TypeBot ()
55 | noResultsSlack t = do
56 |   s <- lift $ asks appSearchEngine
57 |   case removeCommandChars t of
58 |     Just t' -> slack $ notFoundPayload s t'
59 |     Nothing -> return ()
60 | 
61 | notFoundPayload :: SearchEngine -> Text -> Text
62 | notFoundPayload s t = [st|{ "text": "I couldn't find a matching result, here's where I looked: #{humanFriendlyUrl s t}" }|]
63 | 
64 | parseError :: Text
65 | parseError = [st|{ "text": "I couldn't parse the your request..." }|]
66 | 
67 | slackRequest :: SearchResult -> TypeBot ()
68 | slackRequest = slack . typePayload
69 | 
70 | slack :: Text -> TypeBot ()
71 | slack s = do
72 |   cfg <- lift $ asks appConfig
73 |   (Just rToken) <- lookupParameter "token"
74 |   liftIO $ do
75 |     slackUrl <- C.require cfg rToken
76 |     request <- parseUrl slackUrl
77 |     manager <- newManager tlsManagerSettings
78 |     void $ httpLbs (request { method = "POST", requestBody = requestBodyLbs s }) manager
79 | 
80 | typePayload :: SearchResult -> Text
81 | typePayload (SearchResult ts lurl) = [st|{ "text": "`#{ts}`\nHackage docs: #{lurl}" }|]
82 | 
83 | requestBodyLbs :: Text -> RequestBody
84 | requestBodyLbs = RequestBodyLBS . encodeUtf8 . L.fromStrict
85 | 


--------------------------------------------------------------------------------
/src/Utils.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Utils (removeCommandChars, authorized, requireParameter, lookupParameter, opts) where
 4 | 
 5 | import           Control.Monad.IO.Class (liftIO)
 6 | import           Control.Monad.Reader (ask, lift)
 7 | import           Data.Default.Class (def)
 8 | import           Data.Maybe (catMaybes, isJust, listToMaybe)
 9 | import           Data.Text (splitOn, unpack, pack, replace, Text)
10 | import           Data.Text.Internal.Builder(Builder)
11 | import           Data.Text.Lazy.Builder (toLazyText)
12 | import           Data.Text.Lazy.Encoding (decodeUtf8)
13 | import           HTMLEntities.Decoder (htmlEncodedText)
14 | import           Network.HTTP.Types.Status (Status(..))
15 | import           Network.URI (unEscapeString)
16 | import           Network.Wai.Handler.Warp (setPort)
17 | import           System.Environment (getEnv)
18 | import           Types
19 | import           Web.Scotty.Trans (Options, settings, status, body)
20 | import qualified Data.Configurator as C
21 | import qualified Data.Text.Lazy as L
22 | import qualified Network.HTTP.Base as U
23 | import qualified Text.ParserCombinators.ReadP as P
24 | 
25 | opts :: IO Options
26 | opts = do
27 |   port <- webPort
28 |   return def { settings = setPort port $ settings def }
29 | 
30 | authorized :: TypeBot () -> TypeBot ()
31 | authorized action = do
32 |   rToken <- lookupParameter "token"
33 |   match <- tokenMatches rToken
34 |   if match then action else unauthorized
35 | 
36 | tokenMatches :: Maybe Text -> TypeBot Bool
37 | tokenMatches (Just t) = do
38 |   (AppConfig cfg _) <- lift ask
39 |   cToken <- liftIO (C.lookup cfg t :: IO (Maybe Text))
40 |   return $ isJust cToken
41 | tokenMatches Nothing = return False
42 | 
43 | requireParameter :: Text -> (Text -> TypeBot ()) -> TypeBot ()
44 | requireParameter name action = do
45 |   p <- lookupParameter name
46 |   maybe badRequest action p
47 | 
48 | lookupParameter :: Text -> TypeBot (Maybe Text)
49 | lookupParameter name = do
50 |   params <- parseFormEncodedBody . L.toStrict . decodeUtf8 <$> body
51 |   return $ lookup name params
52 | 
53 | badRequest :: TypeBot ()
54 | badRequest = status $ Status 400 "Bad Request"
55 | 
56 | unauthorized :: TypeBot ()
57 | unauthorized = status $ Status 401 "Unauthorized"
58 | 
59 | parseFormEncodedBody :: Text -> [(Text, Text)]
60 | parseFormEncodedBody s = catMaybes $ fmap (arrayToTuple . splitOn "=") (splitOn "&" s)
61 | 
62 | arrayToTuple :: [Text] -> Maybe (Text, Text)
63 | arrayToTuple [x, y] = Just (x,y)
64 | arrayToTuple _ = Nothing
65 | 
66 | webPort :: IO Int
67 | webPort = read <$> getEnv "PORT"
68 | 
69 | removeCommandChars :: Text -> Maybe Text
70 | removeCommandChars t = urlEncode . toHtmlEncodedText . replacePlus <$> parsedCommand' t
71 |   where
72 |     parsedCommand' t'' = pack . snd <$> parsedCommand t''
73 |     parsedCommand t' = listToMaybe $ P.readP_to_S (P.string "%3At+") $ unpack t'
74 | 
75 | toText :: Builder -> Text
76 | toText = L.toStrict . toLazyText
77 | 
78 | toHtmlEncodedText :: String -> Text
79 | toHtmlEncodedText = Utils.toText . htmlEncodedText . pack . unEscapeString
80 | 
81 | replacePlus :: Text -> String
82 | replacePlus = unpack . replace "+" "%20"
83 | 
84 | urlEncode :: Text -> Text
85 | urlEncode = pack . U.urlEncode . unpack
86 | 


--------------------------------------------------------------------------------