From a4e724ebff8a37df874643d5358e38c5c2cc6851 Mon Sep 17 00:00:00 2001 From: Levi Pearson Date: Sun, 31 Jan 2016 20:14:35 -0700 Subject: [PATCH] Updates to build with stack and upstream changes I figured this would be harder considering I haven't touched it in far too long. Didn't take much work at all to get it built and running again, and all tests (such as they are) pass. + stack didn't like the exe and test exe both using Main.hs + filled out other-modules in .cabal at stack's suggestion + EitherT is now ExceptT + pipes-concurrency deprecated `Unbounded` in favor of `unbounded` + tasty's wrapper of HSpec is now in IO + misc minor hLint changes --- .gitignore | 1 + pipes-irc-server.cabal | 23 +++++++++++++++-- src/Pipes/IRC/Server.hs | 2 +- src/Pipes/IRC/Server/IrcMonad.hs | 6 ++--- src/Pipes/IRC/Server/MessageHandler.hs | 6 ++--- stack.yaml | 35 ++++++++++++++++++++++++++ tests/ParseTests.hs | 8 +----- tests/{Main.hs => Test.hs} | 26 +++++++++++-------- 8 files changed, 80 insertions(+), 27 deletions(-) create mode 100644 stack.yaml rename tests/{Main.hs => Test.hs} (92%) diff --git a/.gitignore b/.gitignore index f695882..aff1000 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ cabal.sandbox.config .cabal-sandbox/ +.stack-work/ dist/ diff --git a/pipes-irc-server.cabal b/pipes-irc-server.cabal index 4110081..0b60ccf 100644 --- a/pipes-irc-server.cabal +++ b/pipes-irc-server.cabal @@ -17,9 +17,18 @@ cabal-version: >=1.10 executable pipes-irc-server main-is: Main.hs - other-modules: Pipes.IRC.Message.Parse + other-modules: Pipes.IRC.Message + , Pipes.IRC.Message.Parse , Pipes.IRC.Message.Render , Pipes.IRC.Message.Types + , Pipes.IRC.Server + , Pipes.IRC.Server.Channel + , Pipes.IRC.Server.EventHandler + , Pipes.IRC.Server.IrcMonad + , Pipes.IRC.Server.Log + , Pipes.IRC.Server.Server + , Pipes.IRC.Server.User + , Pipes.IRC.Server.Util , Pipes.IRC.Server.Types , Pipes.IRC.Server.MessageHandler -- other-extensions: @@ -49,7 +58,17 @@ executable pipes-irc-server test-suite tests type: exitcode-stdio-1.0 - main-is: Main.hs + other-modules: Pipes.IRC.Message + , Pipes.IRC.Message.Parse + , Pipes.IRC.Message.Render + , Pipes.IRC.Message.Types + , Pipes.IRC.Server.Channel + , Pipes.IRC.Server.Server + , Pipes.IRC.Server.Types + , Pipes.IRC.Server.User + , Pipes.IRC.Server.Util + , ParseTests + main-is: Test.hs build-depends: base , mtl , containers diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index dd420f4..3112bd5 100644 --- a/src/Pipes/IRC/Server.hs +++ b/src/Pipes/IRC/Server.hs @@ -174,7 +174,7 @@ listenHandler srv (lsock, _) = (hName, _) <- getNameInfo [] True False caddr - (writeEnd, readEnd) <- spawn Unbounded + (writeEnd, readEnd) <- spawn unbounded curTime <- getCurrentTime logLine $ BS.pack $ diff --git a/src/Pipes/IRC/Server/IrcMonad.hs b/src/Pipes/IRC/Server/IrcMonad.hs index e54442a..d7f6fae 100644 --- a/src/Pipes/IRC/Server/IrcMonad.hs +++ b/src/Pipes/IRC/Server/IrcMonad.hs @@ -182,17 +182,17 @@ doQuit qmsg = do -- * Command validation utilities type ErrParam = (IrcReply, [IrcParam]) -type IrcMonadErr = EitherT ErrParam IrcMonad +type IrcMonadErr = ExceptT ErrParam IrcMonad tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad () tellErr (Left (r, ps)) = void $ tellNumeric r ps tellErr _ = return () runValidation :: IrcMonadErr () -> IrcMonad () -runValidation = tellErr <=< runEitherT +runValidation = tellErr <=< runExceptT ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr () -ensure p r ps = unless p $ left (r, ps) +ensure p r ps = unless p $ throwE (r, ps) ensureUse :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a ensureUse u e = lift u >>= hoistEither . note e diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index d4e78cb..92adf1d 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -128,7 +128,7 @@ handleJOIN msg@IrcMessage{..} = runValidation $ do ["0"] -> do cs <- useUserChans nn doPart msg{command=Left PART} (S.elems cs) Nothing -- No passwords were supplied - cs:[] -> doJoin msg $ zipParams (parseParamList cs) [] + [cs] -> doJoin msg $ zipParams (parseParamList cs) [] -- Some number of passwords were supplied cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks) @@ -136,7 +136,7 @@ handlePART :: IrcMessage -> IrcMonad () handlePART msg@IrcMessage{..} = runValidation $ do checkParamLength "PART" params 1 lift $ case params of - cs:[] -> doPart msg (parseParamList cs) Nothing + [cs] -> doPart msg (parseParamList cs) Nothing cs:pm:_ -> doPart msg (parseParamList cs) (Just pm) doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad () @@ -173,7 +173,7 @@ handlePRIVMSG :: IrcMessage -> IrcMonad () handlePRIVMSG msg@IrcMessage{..} = do case params of [] -> tellNumeric err_norecipient [] - _:[] -> tellNumeric err_notexttosend [] + [_] -> tellNumeric err_notexttosend [] rsp:_:_ -> let rs = parseParamList rsp in findReceivers rs >>= fwdMsg msg return () diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..92f5bfa --- /dev/null +++ b/stack.yaml @@ -0,0 +1,35 @@ +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-5.0 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/tests/ParseTests.hs b/tests/ParseTests.hs index 690e7aa..cd79e8c 100644 --- a/tests/ParseTests.hs +++ b/tests/ParseTests.hs @@ -2,21 +2,15 @@ module ParseTests where -import Test.Tasty import Test.Tasty.Hspec as HS import Data.Attoparsec.ByteString.Char8 as P -import Data.ByteString.Char8 as C8 -import Data.List -import Data.Ord import Pipes.IRC.Message.Parse -import Pipes.IRC.Message.Render import Pipes.IRC.Message.Types msgParseSpec :: Spec -msgParseSpec = do - +msgParseSpec = describe "Parsing" $ do describe "parseMsgOrLine" $ do diff --git a/tests/Main.hs b/tests/Test.hs similarity index 92% rename from tests/Main.hs rename to tests/Test.hs index 512b517..cfe976d 100644 --- a/tests/Main.hs +++ b/tests/Test.hs @@ -6,11 +6,8 @@ import Test.Tasty import Test.Tasty.Hspec as HS import Test.Tasty.QuickCheck as QC -import Control.Applicative - import qualified Data.ByteString.Char8 as C8 import Data.List -import Data.Monoid import ParseTests @@ -20,18 +17,25 @@ import Pipes.IRC.Server.Types import Pipes.IRC.Server.User main :: IO () -main = defaultMain tests +main = do + ts <- tests + defaultMain ts -tests :: TestTree -tests = testGroup "Tests" [specs, userProperties, chanProperties] +tests :: IO TestTree +tests = do + sps <- specs + return $ testGroup "Tests" [sps, userProperties, chanProperties] -- Hspec Tests -specs :: TestTree -specs = testGroup "Specifications" - [ HS.testCase "Message Parsing" msgParseSpec --- , HS.testCase "Message Rendering" msgRenderSpec - ] +specs :: IO TestTree +specs = do + mps <- HS.testSpec "Message Parsing" msgParseSpec +-- mrs <- HS.testCase "Message Rendering" msgRenderSpec + return $ testGroup "Specifications" + [ mps +-- , mrs + ] -- QuickCheck and SmallCheck properties {-