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 changesmaster
parent
f8b361dc5b
commit
a4e724ebff
|
@ -1,3 +1,4 @@
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
.cabal-sandbox/
|
.cabal-sandbox/
|
||||||
|
.stack-work/
|
||||||
dist/
|
dist/
|
||||||
|
|
|
@ -17,9 +17,18 @@ cabal-version: >=1.10
|
||||||
|
|
||||||
executable pipes-irc-server
|
executable pipes-irc-server
|
||||||
main-is: Main.hs
|
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.Render
|
||||||
, Pipes.IRC.Message.Types
|
, 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.Types
|
||||||
, Pipes.IRC.Server.MessageHandler
|
, Pipes.IRC.Server.MessageHandler
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
@ -49,7 +58,17 @@ executable pipes-irc-server
|
||||||
|
|
||||||
test-suite tests
|
test-suite tests
|
||||||
type: exitcode-stdio-1.0
|
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
|
build-depends: base
|
||||||
, mtl
|
, mtl
|
||||||
, containers
|
, containers
|
||||||
|
|
|
@ -174,7 +174,7 @@ listenHandler srv (lsock, _) =
|
||||||
|
|
||||||
(hName, _) <- getNameInfo [] True False caddr
|
(hName, _) <- getNameInfo [] True False caddr
|
||||||
|
|
||||||
(writeEnd, readEnd) <- spawn Unbounded
|
(writeEnd, readEnd) <- spawn unbounded
|
||||||
curTime <- getCurrentTime
|
curTime <- getCurrentTime
|
||||||
|
|
||||||
logLine $ BS.pack $
|
logLine $ BS.pack $
|
||||||
|
|
|
@ -182,17 +182,17 @@ doQuit qmsg = do
|
||||||
-- * Command validation utilities
|
-- * Command validation utilities
|
||||||
|
|
||||||
type ErrParam = (IrcReply, [IrcParam])
|
type ErrParam = (IrcReply, [IrcParam])
|
||||||
type IrcMonadErr = EitherT ErrParam IrcMonad
|
type IrcMonadErr = ExceptT ErrParam IrcMonad
|
||||||
|
|
||||||
tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad ()
|
tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad ()
|
||||||
tellErr (Left (r, ps)) = void $ tellNumeric r ps
|
tellErr (Left (r, ps)) = void $ tellNumeric r ps
|
||||||
tellErr _ = return ()
|
tellErr _ = return ()
|
||||||
|
|
||||||
runValidation :: IrcMonadErr () -> IrcMonad ()
|
runValidation :: IrcMonadErr () -> IrcMonad ()
|
||||||
runValidation = tellErr <=< runEitherT
|
runValidation = tellErr <=< runExceptT
|
||||||
|
|
||||||
ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr ()
|
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 :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a
|
||||||
ensureUse u e = lift u >>= hoistEither . note e
|
ensureUse u e = lift u >>= hoistEither . note e
|
||||||
|
|
|
@ -128,7 +128,7 @@ handleJOIN msg@IrcMessage{..} = runValidation $ do
|
||||||
["0"] -> do cs <- useUserChans nn
|
["0"] -> do cs <- useUserChans nn
|
||||||
doPart msg{command=Left PART} (S.elems cs) Nothing
|
doPart msg{command=Left PART} (S.elems cs) Nothing
|
||||||
-- No passwords were supplied
|
-- No passwords were supplied
|
||||||
cs:[] -> doJoin msg $ zipParams (parseParamList cs) []
|
[cs] -> doJoin msg $ zipParams (parseParamList cs) []
|
||||||
-- Some number of passwords were supplied
|
-- Some number of passwords were supplied
|
||||||
cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
|
cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
|
||||||
|
|
||||||
|
@ -136,7 +136,7 @@ handlePART :: IrcMessage -> IrcMonad ()
|
||||||
handlePART msg@IrcMessage{..} = runValidation $ do
|
handlePART msg@IrcMessage{..} = runValidation $ do
|
||||||
checkParamLength "PART" params 1
|
checkParamLength "PART" params 1
|
||||||
lift $ case params of
|
lift $ case params of
|
||||||
cs:[] -> doPart msg (parseParamList cs) Nothing
|
[cs] -> doPart msg (parseParamList cs) Nothing
|
||||||
cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)
|
cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)
|
||||||
|
|
||||||
doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
|
doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
|
||||||
|
@ -173,7 +173,7 @@ handlePRIVMSG :: IrcMessage -> IrcMonad ()
|
||||||
handlePRIVMSG msg@IrcMessage{..} = do
|
handlePRIVMSG msg@IrcMessage{..} = do
|
||||||
case params of
|
case params of
|
||||||
[] -> tellNumeric err_norecipient []
|
[] -> tellNumeric err_norecipient []
|
||||||
_:[] -> tellNumeric err_notexttosend []
|
[_] -> tellNumeric err_notexttosend []
|
||||||
rsp:_:_ -> let rs = parseParamList rsp
|
rsp:_:_ -> let rs = parseParamList rsp
|
||||||
in findReceivers rs >>= fwdMsg msg
|
in findReceivers rs >>= fwdMsg msg
|
||||||
return ()
|
return ()
|
||||||
|
|
|
@ -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
|
|
@ -2,21 +2,15 @@
|
||||||
|
|
||||||
module ParseTests where
|
module ParseTests where
|
||||||
|
|
||||||
import Test.Tasty
|
|
||||||
import Test.Tasty.Hspec as HS
|
import Test.Tasty.Hspec as HS
|
||||||
|
|
||||||
import Data.Attoparsec.ByteString.Char8 as P
|
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.Parse
|
||||||
import Pipes.IRC.Message.Render
|
|
||||||
import Pipes.IRC.Message.Types
|
import Pipes.IRC.Message.Types
|
||||||
|
|
||||||
msgParseSpec :: Spec
|
msgParseSpec :: Spec
|
||||||
msgParseSpec = do
|
msgParseSpec =
|
||||||
|
|
||||||
describe "Parsing" $ do
|
describe "Parsing" $ do
|
||||||
|
|
||||||
describe "parseMsgOrLine" $ do
|
describe "parseMsgOrLine" $ do
|
||||||
|
|
|
@ -6,11 +6,8 @@ import Test.Tasty
|
||||||
import Test.Tasty.Hspec as HS
|
import Test.Tasty.Hspec as HS
|
||||||
import Test.Tasty.QuickCheck as QC
|
import Test.Tasty.QuickCheck as QC
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
|
|
||||||
import qualified Data.ByteString.Char8 as C8
|
import qualified Data.ByteString.Char8 as C8
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Monoid
|
|
||||||
|
|
||||||
import ParseTests
|
import ParseTests
|
||||||
|
|
||||||
|
@ -20,18 +17,25 @@ import Pipes.IRC.Server.Types
|
||||||
import Pipes.IRC.Server.User
|
import Pipes.IRC.Server.User
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain tests
|
main = do
|
||||||
|
ts <- tests
|
||||||
|
defaultMain ts
|
||||||
|
|
||||||
tests :: TestTree
|
tests :: IO TestTree
|
||||||
tests = testGroup "Tests" [specs, userProperties, chanProperties]
|
tests = do
|
||||||
|
sps <- specs
|
||||||
|
return $ testGroup "Tests" [sps, userProperties, chanProperties]
|
||||||
|
|
||||||
-- Hspec Tests
|
-- Hspec Tests
|
||||||
|
|
||||||
specs :: TestTree
|
specs :: IO TestTree
|
||||||
specs = testGroup "Specifications"
|
specs = do
|
||||||
[ HS.testCase "Message Parsing" msgParseSpec
|
mps <- HS.testSpec "Message Parsing" msgParseSpec
|
||||||
-- , HS.testCase "Message Rendering" msgRenderSpec
|
-- mrs <- HS.testCase "Message Rendering" msgRenderSpec
|
||||||
]
|
return $ testGroup "Specifications"
|
||||||
|
[ mps
|
||||||
|
-- , mrs
|
||||||
|
]
|
||||||
|
|
||||||
-- QuickCheck and SmallCheck properties
|
-- QuickCheck and SmallCheck properties
|
||||||
{-
|
{-
|
Loading…
Reference in New Issue