Upgraded MongoDB and stuff

norby.cabal

@@ -23,12 +23,12 @@ executable norby
 
   -- Packages needed in order to build this package.
   build-depends:      base      >= 4     && < 5
-  build-depends:      bson      >= 0.0.3 && <= 0.1
+  build-depends:      bson      >= 0.1   && <= 1.0
   build-depends:      hint      >= 0.3   && <= 1.0
   build-depends:      monads-fd >= 0.1   && <= 1.0
-  build-depends:      mongoDB   >= 0.7   && <= 1.0
-  build-depends:      mueval    >= 0.8   && <= 1.0
-  build-depends:      network   >= 2.2   && <= 2.3
+  build-depends:      mongoDB   >= 0.8   && <= 1.0
+  -- build-depends:      mueval    >= 0.8   && <= 1.0
+  build-depends:      network   >= 2.3   && <= 3.0
   build-depends:      parsec    >= 2.0   && <= 3.0
   build-depends:      process   >= 1.0   && <= 2.0
   build-depends:      time      >= 1.1.4 && <= 1.2
@@ -39,4 +39,4 @@ executable norby
   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
   -- Build-tools:         
 
-  ghc-options:        -Wall -threaded
+  ghc-options:        -Wall -threaded

src/Eval.hs

@@ -4,8 +4,8 @@ import           Control.Monad.Reader
 import           Data.Char
 import           Data.List
 
-import           Mueval.ArgsParse
-import           Mueval.Interpreter
+--import           Mueval.ArgsParse
+--import           Mueval.Interpreter
 
 import qualified Language.Haskell.Interpreter as I
 
@@ -28,6 +28,7 @@ evalHsExt (Message _ _ params) = do
                   , "-t30" ]
 
 -- Evaluate a Haskell expression
+{-
 evalHs :: String -> IO String
 evalHs expr = do
     rt <- liftIO . I.runInterpreter . interpreter $ muOptions { expression = expr }
@@ -40,6 +41,7 @@ evalHs expr = do
     where muOptions = (getOptions []) { expression = expr
                                       , loadFile   = hsFile
                                       , timeLimit  = 5 }
+-}
 
 -- Get inferred type of an expression
 typeOf :: Message -> IO String

src/IRC.hs

@@ -38,14 +38,14 @@ connect s p = notify $ do
                     (print "It is so.") a
 
 write :: Message -> Net ()
-write msg = asks socket >>= \h -> liftIO $ hPrint h msg
-                        >> S.store msg >> putStrLn ("sent: " ++ (show msg))
+write msg = asks socket >>= \h -> liftIO $ hPrint h (encode msg)
+                        >> S.store msg >> putStrLn ("sent: " ++ (encode msg))
 
 -- Process lines from the server
 listen :: Handle -> Net ()
 listen h = forever $ do
     s <- fmap init . liftIO $ hGetLine h
-    let Just msg = parseMessage s -- Uh oh! NON-EXHAUSTIVE PATTERNS
+    let Just msg = decode s -- Uh oh! NON-EXHAUSTIVE PATTERNS
     _ <- liftIO ((putStrLn $ "got:  " ++ s) >> S.store msg) -- Store every message in MongoDB
     eval msg
 

src/L.hs

@@ -13,6 +13,7 @@ import           Data.List.Split
 import           Data.Maybe
 import           Data.Monoid
 import           Data.Ratio
+import           Network.URI
 import           Numeric
 import           Text.Printf
 import           Text.Regex
@@ -73,7 +74,7 @@ nlogax     = (++ "n't")               :: String -> String
 paul_irish = ($)                      :: (effin -> rad) -> effin -> rad
 rwaldron   = (++ ". Questions?")      :: String -> String
 sean       = "koole"                  :: String
-seutje     = ("I would of " ++)       :: String -> String
+seutje     = ("I would have " ++)     :: String -> String
 temp01     = Just "awesome"           :: Maybe String
 vladikoff  = ("flod " ++) . (++ "!!") :: String -> String
 
@@ -114,4 +115,4 @@ infixl 0 &
 x & f = f x
 
 ftoc t = 5/9 * (t - 32)
-ctof t = (9/5 * t) + 32
+ctof t = (9/5 * t) + 32

src/Main.hs

@@ -16,8 +16,8 @@ main = bracket (connect server port) disconnect loop
 
 -- Join some channels, and start processing commands
 run :: Net ()
-run = do
-    mapM_ write [ Message Nothing "NICK" [nick]
-                , Message Nothing "USER" [nick, "0", "*", name]
-                , Message Nothing "JOIN" [channels] ]
-    asks socket >>= listen
+run = mapM_ write [ Message Nothing "NICK" [nick]
+                  , Message Nothing "USER" [nick, "0", "*", name]
+                  , Message Nothing "JOIN" [channels]
+                  ]
+         >> asks socket >>= listen

src/Parser.hs

@@ -1,11 +1,11 @@
-module Parser (parseMessage) where
+module Parser (decode) where
 
 import           Data.Maybe
 import           Text.ParserCombinators.Parsec hiding (letter, space)
 import           Types
 
-parseMessage :: String -> Maybe Message
-parseMessage s = either (const Nothing) Just (parse message "Message" s)
+decode :: String -> Maybe Message
+decode s = either (const Nothing) Just (parse message "Message" s)
 
 message :: CharParser () Message
 message = do

src/Seen.hs

@@ -14,37 +14,32 @@ import           Types
 
 import qualified Utils as U
 
-hostIP = "127.0.0.1"
-dbName = "seen"
+collection :: Collection
 collection = "messages"
 
-run c d    = runNet $ runConn (useDb dbName d) c
+run action = do
+    pool <- newConnPool 1 $ host "127.0.0.1"
+    access safe Master pool $ use (Database "seen") action
 
-connectDb  = runNet . connect $ host hostIP
-
-store :: Message -> IO String
+store :: Message -> IO ()
 store (Message (Just (NickName nick _ _)) cmd params) = do
-      conn <- connectDb
       now  <- getCurrentTime
       let mess = last params
       let chan = head params
-      let message = ["nick" =: nick, "text" =: mess, "what" =: cmd,
-                     "chan" =: chan, "date" =: now]
-      either (const $ return "MongoDB is down!")
-             ((>> return "Stored.") . flip run (insert collection message))
-             conn
+      let message = [ "nick" =: nick, "text" =: mess, "what" =: cmd
+                    , "chan" =: chan, "date" =: now ]
+      run (insert collection message) >> return ()
 
-store (Message _ _ _) = return "LOL!!" :: IO String
+store (Message _ _ _) = return ()
 
 seen (Message (Just (NickName n _ _)) _ params)
     | n    == nick   = return $ printf "%s: That's you, I see you in %s right now." n chan
     | nick == S.nick = return $ printf "%s: That's me, I am here in %s." n chan
     | otherwise      = do
-        conn <- connectDb
-        either (const $ return "MongoDB is down!")
-               (\c -> run c (findNick nick) >>= \a -> case a of
-                      Right (Right v) -> result v
-                      _               -> return "Kasplode") conn
+              a <- run (findNick nick)
+              case a of
+                   (Right v) -> result v
+                   _         -> return "DOOOOM"
 
      where findNick nn =
                     findOne (select ["nick" =: Regex
@@ -79,9 +74,9 @@ escape (c:cs) = esc c ++ escape cs
 formatSeen :: String -> String -> String -> String
 formatSeen msg "PRIVMSG" chan
     | "\SOHACTION" `isPrefixOf` msg = printf "in %s, actioning *%s*" chan
-                                             (U.excerpt 100 "..." . init . drop 8 $ U.trim msg)
+                                             (U.excerpt 150 "..." . init . drop 8 $ U.trim msg)
     | otherwise = printf "in %s, saying: %s" chan
-                         (U.excerpt 100 "..." $ U.trim msg)
+                         (U.excerpt 150 "..." $ U.trim msg)
 
 formatSeen m cmd c = case cmd of
     "PART" -> printf "leaving %s" c

src/Settings.hs

@@ -12,7 +12,8 @@ channels = intercalate "," [ "#clojure"
                            , "#jquery"
                            , "#jquery-ot"
                            , "#nlogax"
-                           , "#runlevel6" ]
+                           , "#runlevel6"
+                           ]
 
 -- Authorized bot wranglers
 admins = [ "ajpiano"
@@ -26,4 +27,5 @@ admins = [ "ajpiano"
          , "nlogax"
          , "paul_irish"
          , "seutje"
-         , "temp01" ]
+         , "temp01"
+         ]

src/Types.hs

@@ -18,19 +18,19 @@ type RealName   = String
 type ServerName = String
 type UserName   = String
 
--- HMMM: Is this bad use of the Show class?
-instance Show Message where
-         show (Message (Just prefix) command params) =
-               intercalate " " [show prefix, command,
-                                paramize params]
-         show (Message Nothing command params) =
-               intercalate " " [command, paramize params]
+encode (Message (Just prefix) command params) =
+        intercalate " " [ penc prefix
+                        , command
+                        , paramize params
+                        ]
+        where penc (Server s) = ':' : s
+              penc (NickName nick user server) = ':' : nick
+                                   ++ maybe "" ('!' :) user
+                                   ++ maybe "" ('@' :) server
+encode (Message Nothing command params) =
+        intercalate " " [ command
+                        , paramize params ]
 
-instance Show Prefix where
-         show (Server s) = ':' : s
-         show (NickName nick user server) = ':' : nick
-                              ++ maybe "" ('!' :) user
-                              ++ maybe "" ('@' :) server
 
 paramize :: Params -> String
 paramize []  = ""