top (empty) → 0.2
raw patch · 26 files changed
+1881/−0 lines, 26 filesdep +ListLikedep +acid-statedep +asyncsetup-changed
Dependencies added: ListLike, acid-state, async, base, bytestring, containers, data-default-class, deepseq, directory, doctest, extra, filemanip, filepath, flat, ghcjs-base, hslogger, mtl, pipes, pretty, safecopy, stm, tasty, tasty-hunit, template-haskell, text, th-lift, time, top, transformers, websockets, zm
Files
- LICENSE +30/−0
- README.md +128/−0
- Setup.hs +2/−0
- src/Data/Pattern.hs +6/−0
- src/Data/Pattern/TH.hs +84/−0
- src/Data/Pattern/Transform.hs +74/−0
- src/Data/Pattern/Types.hs +121/−0
- src/Data/Pattern/Util.hs +60/−0
- src/Network/Top.hs +12/−0
- src/Network/Top/Pipes.hs +52/−0
- src/Network/Top/Repo.hs +110/−0
- src/Network/Top/Run.hs +125/−0
- src/Network/Top/Types.hs +293/−0
- src/Network/Top/Util.hs +175/−0
- src/Network/Top/WebSockets.hs +297/−0
- src/Repo/DB.hs +74/−0
- src/Repo/Disk.hs +22/−0
- src/Repo/Memory.hs +22/−0
- src/Repo/Types.hs +8/−0
- stack.yaml +11/−0
- stack710.yaml +11/−0
- stack801.yaml +11/−0
- stack802.yaml +11/−0
- test/DocSpec.hs +7/−0
- test/RepoSpec.hs +30/−0
- top.cabal +105/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Pasqualino `Titto` Assini (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Pasqualino `Titto` Assini nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,128 @@++[](https://travis-ci.org/tittoassini/top) [](http://hackage.haskell.org/package/top)++Haskell API for [Top (Type Oriented Protocol)](http://quid2.org/docs/Top.pdf).++### Why Bother?++Imagine visiting your favourite open shelf library or bookshop and discovering that overnight some ill-advised employee has reordered the whole collection by publishing house. All books from Oxford University Press or Penguin are now neatly grouped together.++That would look nice and orderly for sure, with all those similarly designed book spines standing side by side.++But obviously, this semblance of order would be nothing but a travesty as it would be close to impossible to locate what you are really after, and that's usually not "some book from Penguin" but rather a book about Thai cooking or the latest novel by Mo Yan.++Wake up, it was just a nightmare. Nobody would be so stupid to order human knowledge in such a nonsensical way, would they?++Except, now that you make me think about it, this is exactly how information is ordered by default in the ultimate library, the Internet. On the World Wide Web, for example, information is accessed by website, and a website is nothing but a collection of information made available from some publisher. And that, unsurprisingly, causes a bit of trouble when you are actually looking for some specific type of information.++Someone had to fix the problem, patiently reorganising the Internet library by type and subject, and in fact [someone](http://google.com) did and, as reward for their efforts, even managed to make a [little dough](http://finance.yahoo.com/q?s=GOOG) out of it. Who said that being a good librarian doesn't pay the bills?+++The root of the problem is the way information is accessed and transferred on the Internet. The communication protocol at the heart of the Web, the [HTTP](https://en.wikipedia.org/wiki/Hypertext_Transfer_Protocol), as in fact those of most widely used Internet systems, is a point-to-point protocol.++Point-to-point simply means that information flows from A to B where A and B are publishers and/or consumers of information. It is the simplest but not always the most convenient form of communication as it's often the case that A does not in fact want to communicate with B at all, but would rather talk about *something* or exchange some specific *type* of information.++Say for example that you have some excellent jokes that you would be willing to share with the world. You don't want to call Joe and then Jake and then Marian to make them laugh. You want to make people, not a specific person, laugh. Now say that you could simply define what a joke is and then start sending them out and that anyone interested could tune in and have a good time reading them and sending out their own.++We might define a joke, in a very simple way, as:++```haskell+Joke ≡ Joke Text+````+that basically means: 'a joke is just a text marked as being a joke'.++And then we could simply start sending out jokes by writing a little program that says something like:++```haskell+jokesChannel <- openChannelOfType Joke++send jokesChannel (Joke "Notice on an Italian bus: don’t talk to the driver, he needs his hands.")+```+Funny eh :-)?++Maybe not, but that's not a problem, you are free to send out your own jokes.++Because what we have just done, by the simple act of defining some type of information and sending out an item of that type, is to create a big fat global channel where jokes can now flow.++And that's precisely how Top, the type oriented protocol, works.++### Top (Type Oriented Protocol)++Top is a minimalist content-oriented transport protocol ([spec](http://quid2.org/docs/Top.pdf)).++In Top, all communication takes place on bi-directional *typed* channels, that's to say on channels that transfer only values of a well-defined algebraic data type.++Data does not flow from A to B but rather all data of the same type flows on a single, globally unique, channel and anyone can define new data types and send and receive data values.++You can [see it in action](http://quid2.org/app/ui).++Under the *Channels* tab are listed the currently open channels, every channel has a type and you can see its full definition by clicking on *Definition*.++Definitions are just [plain algebraic data types](https://github.com/tittoassini/zm).++For example, you should see a *Message* channel that is used to implement a simple chat system. Click on *Show Values* to inspect the value being transferred and then use the [chat user interface](http://quid2.org/app/chat) to login and send a couple of messages and see them appear on the channel.++Under the *Types* tab is the list of types known to the system.++#### Minimalist but Evolvable++Top does not provide any other service beyond full-duplex typed communication, any other service (e.g. identification or encryption) has to be provided by the clients themselves but that can be done easily and independently by simply creating data types that stands for the additional functionality required.++### Usage++Using Top can be as simple as:++```haskell+{-# LANGUAGE DeriveGeneric ,DeriveAnyClass #-}+import Network.Top++-- |Send a message and then print out all messages received+main = runApp def ByType $ \conn -> do+ logLevel DEBUG+ output conn Message {fromUser="robin",content=TextMessage "Hello!"}+ loop conn+ where loop conn = input conn >>= print >> loop conn++-- Data model for a very simple chat system+data Message = Message {+ fromUser::String+ ,content::Content+ } deriving (Eq, Ord, Read, Show, Generic , Flat, Model)++data Content =+ TextMessage String++ | HTMLMessage String+ deriving (Eq, Ord, Read, Show, Generic, Flat, Model)+```+<sup>[Source Code](https://github.com/tittoassini/top-apps/blob/master/app/hello.hs)</sup>++For examples of stand-alone and www applications see:++* [top-apps-ghcjs](https://github.com/tittoassini/top-apps-ghcjs)+ * Example WWW applications for [top](https://github.com/tittoassini/top), using [ghcjs](https://github.com/ghcjs/ghcjs).+* [top-apps](https://github.com/tittoassini/top-apps)+ * Example applications for [top](https://github.com/tittoassini/top).++#### Installation++ Get the latest stable version from [hackage](https://hackage.haskell.org/package/top).++#### Compatibility++Tested with:+ * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1 and 8.0.2 (x64)+ * [ghcjs](https://github.com/ghcjs/ghcjs)++So it can be used to develop both stand alone and WWW applications.++### The Top Service.++Though Top is eventually meant to develop into a distributed, vendor-free, protocol compatible with multiple transport protocols, its current implementation is provided by a single central router that supports [websockets](https://en.wikipedia.org/wiki/WebSocket) and therefore full-duplex, HTTP compatible channels.++TERMS OF SERVICE:+* The Top service is offered by Quid2 Limited - Registered in England and Wales - Reg No: 09213600.+* There is no charge for fair usage of the Top service. +* Fair usage is defined as any usage that does not lead to a *de facto* denial of service to other users or that imposes unreasonable expense on its maintainer.+* By using the Top service you accept that the service is offered "as is" with no express or implied warranty for availability, performance, consistency, longevity or functionality.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Pattern.hs view
@@ -0,0 +1,6 @@+-- |Patterns (for ByPattern channels)+module Data.Pattern(module X) where++import Data.Pattern.TH as X+import Data.Pattern.Types as X+import Data.Pattern.Transform as X
+ src/Data/Pattern/TH.hs view
@@ -0,0 +1,84 @@+-- |Convert a Template Haskell pattern to a Pattern+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Pattern.TH (patternQ, patternE) where++import Data.Pattern.Types+import Language.Haskell.TH hiding (Match, Pat, Type)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax hiding (Match, Type, Pat)+import Network.Top.Types ()++-- |Template Haskell function to convert an Haskell pattern to an `IPattern`+--+-- @+-- $(patternE [p|_|]) == PName PWild+-- @+--+-- Note: no support for negative integers or tuples with more than 5 elements+patternE :: Q TH.Pat -> Q Exp+patternE pat = asPatternM pat >>= lift++-- |Template Haskell function to convert an Haskell pattern to an `IPattern`+--+-- @+-- patternQ [p|_|] :: IO IPattern+-- PName PWild+-- @+--+patternQ :: Quasi m => Q TH.Pat -> m IPattern+patternQ = runQ . asPatternM++asPatternM :: Monad m => m TH.Pat -> m IPattern+asPatternM = (conv <$>)+ where+ conv :: TH.Pat -> IPattern+ conv pat = case pat of+ ConP n [] | name n == "[]" -> PCon "Nil" []++ ConP n args -> PCon (name n) $ map conv args++ ListP ps -> convList $ map conv ps++ VarP n -> PName $ PVar (name n)++ WildP -> PName PWild++ ParensP p -> conv p++ InfixP p1 (Name (OccName ":" ) (NameG DataName (PkgName "ghc-prim") (ModName "GHC.Types"))) p2 -> (\a b -> PCon "Cons" [a,b]) (conv p1) (conv p2)++ TupP [p1,p2] -> (\a b -> PCon "Tuple2" [a,b]) (conv p1) (conv p2)+ TupP [p1,p2,p3] -> (\a b c -> PCon "Tuple3" [a,b,c]) (conv p1) (conv p2) (conv p3)+ TupP [p1,p2,p3,p4] -> (\a b c d -> PCon "Tuple4" [a,b,c,d]) (conv p1) (conv p2) (conv p3) (conv p4)+ TupP [p1,p2,p3,p4,p5] -> (\e1 e2 e3 e4 e5 -> PCon "Tuple5" [e1,e2,e3,e4,e5]) (conv p1) (conv p2) (conv p3) (conv p4) (conv p5)++ -- RecP --++ LitP l -> case l of+ CharL c -> PName . PChar $ c+ StringL s -> PName . PString $ s+ IntegerL i -> PName . PInt $ i+ RationalL r -> PName . PRat $ r+ _ -> error . unwords $ ["Unsupported literal",show l]++ _ -> error . unwords $ ["Unsupported pattern",show pat] -- pprint p,show p]+++ convList :: [Pat v] -> Pat v+ convList [] = PCon "Nil" []+ convList (h:t) = PCon "Cons" [h,convList t]++ name :: Name -> String+ name (Name (OccName n) _) = n++-- asExp (PCon n ps) = AppE (AppE (c "Data.Pattern.Con") (LitE (StringL n))) (ListE (map asExp ps))+-- asExp (PName (V v)) = VarE (mkName v)+-- asExp (PName W) = AppE (c "Data.Pattern.Var") (c "W")++-- c = ConE . mkName++++
+ src/Data/Pattern/Transform.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |Convert an Haskell pattern to the corresponding `ByPattern` channel identifier+module Data.Pattern.Transform (byPattern, byPattern_) where++import qualified Data.Flat.Bits as V+import Data.Int+import qualified Data.ListLike.String as L+import qualified Data.Map as M+import Data.Pattern.Types+import Data.Pattern.Util+import Data.Word+import ZM hiding (Name)++-- |Convert an Haskell pattern to the corresponding `ByPattern` channel identifier+-- or throw an error if conversion fails+byPattern :: forall a. Model a => IPattern -> ByPattern a+byPattern = either error id . byPattern_++-- |Convert an Haskell pattern to the corresponding `ByPattern` channel identifier+byPattern_ :: forall a. Model a => IPattern -> Either String (ByPattern a)+byPattern_ pat =+ let tm = absTypeModel (Proxy :: Proxy a)+ ctMap = typeTree tm+ solveCons t = let Just ct = M.lookup t ctMap in (ct,t)++ conv (PCon n ps) (ct,t) =+ case constructorInfo (L.fromString n) ct of+ Nothing -> err ["Constructor '"++ n ++"' not present in",show t]+ Just (bs,ts) | length ts == length ps -> Right (MatchValue . map boolToBit $ bs) : concatMap (uncurry conv) (zip ps $ map solveCons ts)+ | otherwise -> err ["Constructor",n,"has",show (length ts),"parameters, found",show (length ps)]++ conv (PName (PInt i)) (_,t) | t==word8Type = val (fromIntegral i::Word8)+ | t==word16Type = val (fromIntegral i::Word16)+ | t==word32Type = val (fromIntegral i::Word32)+ | t==word64Type = val (fromIntegral i::Word64)+ | t==wordType = val (fromIntegral i::Word)+ | t==int8Type = val (fromIntegral i::Int8)+ | t==int16Type = val (fromIntegral i::Int16)+ | t==int32Type = val (fromIntegral i::Int32)+ | t==int64Type = val (fromIntegral i::Int64)+ | t==intType = val (fromIntegral i::Int)+ | t==integerType = val (fromIntegral i::Integer)+ | otherwise = terr t i++ conv (PName (PRat r)) (_,t)| t==floatType = val (fromRational r::Float)+ | t==doubleType = val (fromRational r::Double)+ | otherwise = terr t r++ conv (PName (PChar c)) (_,t) | t == charType = val c+ | otherwise = terr t c++ conv (PName (PString s)) (_,t) | t == stringType = val s+ | otherwise = terr t s++ conv (PName PWild) (_,t) = [Right $ MatchAny t]++ conv (PName (PVar v)) _ = err ["Variables are not allowed in patterns, use wildcards (_) only, found:",v]++ --conv p _ = error (show p)++ in ByPattern . optPattern <$> collectErrors (conv pat (solveCons (typeName tm)))++ where+ val a = [Right . MatchValue . map boolToBit . V.toBools . V.bits $ a]+ err ls = [Left . unwords $ ls]+ terr expType r = err ["Type mismatch: expected",show expType,"type, found",show r]++boolToBit False = V0+boolToBit True = V1
+ src/Data/Pattern/Types.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- |Pattern related types+module Data.Pattern.Types (+ Matcher,++ -- *Top patterns+ ByPattern(..),+ Pattern,+ Match(..),+ Bit(..),+ optPattern,++ -- *Internal patterns+ IPattern,+ Pat(..),+ PRef(..),+ --WildCard(..)+ ) where++import qualified Data.ByteString as B+import ZM hiding (Con, Name, Var)+import ZM.Type.Bit++-- |A matcher is a predicate defined over the binary representation of a value+type Matcher = B.ByteString -> Bool++{-|+A routing protocol specified by a pattern and a type.++Once a connection is established, clients:++ * can send messages of the given type++ * will receive all messages of the same type, that match the given pattern, sent by other agents+-}+newtype ByPattern a = ByPattern Pattern+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (ByPattern a)++-- |A Pattern is just a list of matches, values are represented by their Flat binary serialisation+type Pattern = [Match [Bit]]+-- instance Flat [Match [Bit]]++-- |Match either a flattened value of any value of a given type+data Match v = MatchValue v -- ^Match the specified value+ | MatchAny (Type AbsRef) -- ^Match any value of the given type (wildcard)+ deriving (Show, Eq, Ord, Generic, Flat,Functor)++instance Model v => Model (Match v)++-- |Optimise a Pattern by concatenating adjacent value matches+optPattern :: Pattern -> Pattern+optPattern (MatchValue []:t) = optPattern t+optPattern (MatchValue bs:MatchValue bs':t) = optPattern $ MatchValue (bs ++ bs'):t+optPattern (x:xs) = x : optPattern xs+optPattern [] = []++-- |Internal pattern representation+type IPattern = Pat PRef++-- |Pattern representation used for internal processing+data Pat v =+ -- |A constructor+ PCon {pConsName::String -- ^Name of the constructor (e.g. "True")+ ,pConsParameters::[Pat v] -- ^Constructor parameters+ }++ -- |A primitive value (for example `PRef`)+ | PName v++ deriving (Eq, Ord, Show)++--instance Model v => Model (Pat v)++-- |Literals and variables+data PRef = PInt Integer+ | PRat Rational+ | PChar Char+ | PString String+ | PWild+ | PVar String+ deriving (Eq, Ord, Show)++-- -- |A Variable that can be either a name (e.g. "a") or a wildcard "_"+-- data VarOrWild = V String+-- | W+-- deriving (Eq, Ord, Show, Generic, Flat, Model)+-- --+-- -- isVar :: VarOrWild -> Bool+-- isVar (V _) = True+-- isVar _ = False++-- -- |A wildcard "_", that matches any value+-- data WildCard = WildCard+-- deriving (Eq, Ord, Show, Generic, Flat, Model)++-- onlyWildCards :: VarOrWild -> WildCard+-- onlyWildCards W = WildCard+-- onlyWildCards _ = error "Only wildcards (_) are allowed"++-- List Pattern _:_+-- prefixPattern :: (Foldable t, Flat a) => t a -> Pattern HVar+-- prefixPattern = listPatt (PVar W)++--listPatt :: (Foldable t, Flat a) => Pattern v -> t a -> Pattern v+--listPatt = foldr (\a p -> PCon "Cons" [valPattern a,p])++-- showPatt :: Pat VarOrWild -> String+-- showPatt (PCon n ps) = unwords ["Data.Pattern.Con",show n,"[",intercalate "," . map showPatt $ ps,"]"]+-- showPatt (PName (V v)) = v -- concat ["val (",v,")"] -- showVar v+-- --showPatt (Var W) = "Var W" -- "WildCard" -- "WildCard" -- "_"+-- showPatt p = show p -- show bs -- concat [Data.BitVector,show bs+
+ src/Data/Pattern/Util.hs view
@@ -0,0 +1,60 @@+-- |Utilities+module Data.Pattern.Util where++import Data.Either+import Data.Int+import Data.Word+import ZM++-- chkErrors :: [Either String b] -> [b]+-- chkErrors = either error id . collectErrors++collectErrors :: [Either String b] -> Either String [b]+collectErrors r = if null (lefts r)+ then Right $ rights r+ else Left $ unlines $ lefts r++stringType :: Type AbsRef+stringType = absType (Proxy::Proxy String)++charType :: Type AbsRef+charType = absType (Proxy::Proxy Char)++word8Type :: Type AbsRef+word8Type = absType (Proxy::Proxy Word8)++word16Type :: Type AbsRef+word16Type = absType (Proxy::Proxy Word16)++word32Type :: Type AbsRef+word32Type = absType (Proxy::Proxy Word32)++word64Type :: Type AbsRef+word64Type = absType (Proxy::Proxy Word64)++wordType :: Type AbsRef+wordType = absType (Proxy::Proxy Word)++int8Type :: Type AbsRef+int8Type = absType (Proxy::Proxy Int8)++int16Type :: Type AbsRef+int16Type = absType (Proxy::Proxy Int16)++int32Type :: Type AbsRef+int32Type = absType (Proxy::Proxy Int32)++int64Type :: Type AbsRef+int64Type = absType (Proxy::Proxy Int64)++intType :: Type AbsRef+intType = absType (Proxy::Proxy Int)++integerType :: Type AbsRef+integerType = absType (Proxy::Proxy Integer)++floatType :: Type AbsRef+floatType = absType (Proxy::Proxy Float)++doubleType :: Type AbsRef+doubleType = absType (Proxy::Proxy Double)
+ src/Network/Top.hs view
@@ -0,0 +1,12 @@+module Network.Top (+-- |Check the <https://github.com/tittoassini/top tutorial and github repo>.+module X) where++import Data.Pattern as X+import Network.Top.Pipes as X+import Network.Top.Repo as X+import Network.Top.Run as X+import Network.Top.Types as X+import Network.Top.Util as X+import Network.Top.WebSockets as X+import ZM as X
+ src/Network/Top/Pipes.hs view
@@ -0,0 +1,52 @@+-- |Access Top connections as Pipes+module Network.Top.Pipes (+ pipeIn,+ pipeOut,++ -- *Re-exports from Pipe+ runEffect,+ (>->),+ yield,+ for,+ await,+ lift,+ ) where++import Data.Flat+import Network.Top.Types+import Pipes++-- |Receive values from a typed connection, terminate when connection is closed+pipeIn :: (Show a, MonadIO m,Flat a) => Connection a -> Producer a m ()+-- pipeIn conn = loop+-- where+-- loop = do+-- mv <- liftIO $ input conn+-- case mv of+-- Nothing -> return ()+-- Just v -> do+-- yield v+-- loop++-- |Send values on a typed connection, terminate when connection is closed+pipeOut :: (Show a, MonadIO m,Flat a) => Connection a -> Consumer a m ()+-- pipeOut conn = loop+-- where+-- loop = do+-- v <- await+-- alive <- liftIO $ output conn v+-- when alive loop++pipeIn conn = loop+ where+ loop = do+ v <- liftIO $ input conn+ yield v+ loop++pipeOut conn = loop+ where+ loop = do+ v <- await+ liftIO $ output conn v+ loop
+ src/Network/Top/Repo.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- |Permanently register and retrieve absolute type definitions+module Network.Top.Repo (RepoProtocol(..), recordType, solveType, knownTypes) where++import Control.Monad+import Data.Either.Extra (lefts)+import Data.List (nub)+import qualified Data.Map as M+import Network.Top.Run+import Network.Top.Types+import Network.Top.Util+import Repo.Types+import ZM++{-|+A (simplistic) protocol to permanently store and retrieve ADT definitions.+-}+data RepoProtocol = Record AbsADT -- ^Permanently record an absolute type+ | Solve AbsRef -- ^Retrieve the absolute type+ | Solved AbsRef AbsADT -- ^Return the absolute type identified by an absolute reference+ | AskDataTypes -- ^Request the list of all known data types+ | KnownDataTypes [(AbsRef, AbsADT)] -- ^Return the list of all known data types+ deriving (Eq, Ord, Show, Generic, Flat, Model)++--instance Flat [(AbsRef,AbsADT)]++type RefSolver = AbsRef -> IO (Either RepoError AbsADT)+-- type TypeSolver = AbsType -> IO (Either RepoError AbsTypeModel)+type RepoError = String -- SomeException++-- |Permanently record an ADT definition+recordType :: Model a => Config -> Proxy a -> IO ()+recordType cfg proxy = runApp cfg ByType $ \conn -> mapM_ (output conn . Record) . absADTs $ proxy++-- |Retrieve all known data types+knownTypes :: Config -> IO (Either String [(AbsRef, AbsADT)])+knownTypes cfg = runApp cfg ByType $ \conn -> do+ output conn AskDataTypes++ let loop = do+ msg <- input conn+ case msg of+ KnownDataTypes ts -> return ts+ _ -> loop++ withTimeout 30 loop++-- |Retrieve the full type model for the given absolute type+-- from Top's RepoProtocol channel, using the given Repo as a cache+solveType :: Repo -> Config -> AbsType -> IO (Either RepoError AbsTypeModel)+solveType repo cfg t = ((TypeModel t . M.fromList) <$>) <$> solveType_ repo cfg t+ where+ solveType_ :: Repo -> Config -> AbsType -> IO (Either RepoError [(AbsRef,AbsADT)])+ solveType_ repo cfg t = runApp cfg ByType $ \conn -> (solveRefsRec repo (resolveRef__ conn)) (references t)++ solveRefsRec :: Repo -> RefSolver -> [AbsRef] -> IO (Either RepoError [(AbsRef,AbsADT)])+ solveRefsRec _ _ [] = return $ Right []+ solveRefsRec repo solver refs = do+ er <- allErrs <$> mapM (solveRef repo solver) refs+ case er of+ Left err -> return $ Left err+ Right ros -> (nub . (ros ++) <$>) <$> solveRefsRec repo solver (concatMap (innerReferences . snd) ros)++ allErrs :: [Either String r] -> Either String [r]+ allErrs rs =+ let errs = lefts rs+ in if null errs+ then sequence rs+ else Left (unlines errs)++ solveRef :: Repo -> RefSolver -> AbsRef -> IO (Either RepoError (AbsRef,AbsADT))+ solveRef repo solver ref = ((ref,) <$> )<$> do+ rr <- get repo ref+ case rr of+ Nothing -> solver ref >>= mapM (\o -> put repo o >> return o)+ Just o -> return $ Right o++resolveRef :: Config -> AbsRef -> IO (Either String AbsADT)+resolveRef cfg ref = checked $ resolveRef_ cfg ref++resolveRef_ cfg ref = runApp cfg ByType (flip resolveRef__ ref)++resolveRef__ :: Connection RepoProtocol -> AbsRef -> IO (Either String AbsADT)+resolveRef__ conn ref = checked $ resolveRef___ conn ref++resolveRef___ :: Connection RepoProtocol -> AbsRef -> IO (Either String AbsADT)+resolveRef___ conn ref = do+ output conn (Solve ref)++ let loop = do+ msg <- input conn+ case msg of+ -- Solved t r | t == typ -> return $ (\e -> AbsoluteType (M.fromList e) typ) <$> r+ Solved sref sadt | ref == sref && absRef sadt == sref -> return $ Right sadt+ _ -> loop++ join <$> withTimeout 25 loop++absADTs :: Model a => Proxy a -> [AbsADT]+absADTs = typeADTs . absTypeModel++checked :: NFData b => IO (Either String b) -> IO (Either String b)+checked f = either (Left . show) id <$> strictTry f
+ src/Network/Top/Run.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |Run processed connected to Top+module Network.Top.Run (+ runAppForever,+ runApp,+ runAppWith+ ) where++import Data.ByteString (ByteString)+import Network.Top.Types+import Network.Top.Util+import Network.Top.WebSockets+import ZM++-- |Permanently connect an application to a typed channel.+-- |Restart application in case of network or application failure.+-- |NOTE: does not provide a way to preserve application's state+runAppForever :: (Model (router a), Flat (router a),Show (router a),Flat a,Show a) =>+ Config -- ^ Top configuration+ -> router a -- ^ Routing protocol+ -> App a r -- ^ Application to connect+ -> IO r -- ^ Value returned from the application+runAppForever cfg router app = forever $ do+ Left (ex :: SomeException) <- try $ runApp cfg router $ \conn -> do+ liftIO $ dbgS "connected"+ app conn++ -- Something went wrong, wait a few seconds and restart+ dbg ["Exited loop with error",concat ["'",show ex,"'"],"retrying in a bit."]+ threadDelay $ seconds 5++-- |Connect an application to a typed channel.+runApp ::+ (Model (router a), Flat (router a),Show (router a),Flat a,Show a) =>+ Config -- ^ Top configuration+ -> router a -- ^ Routing protocol+ -> App a r -- ^ Application to connect+ -> IO r -- ^ Value returned from the application+runApp cfg router app = do+ dbg ["run",show router]+ runAppWith cfg (typedBLOB router) (\conn -> app (Connection (receive conn) (send conn) (close conn)))++-- |Connect an application to a typed channel+runAppWith :: Config -- ^ Top configuration+ -> TypedBLOB -- ^ Routing protocol+ -> App ByteString r -- ^ Application to connect+ -> IO r -- ^ Value returned from the application+runAppWith cfg routerBin app = run cfg 1+ where+ run _ 4 = errIn "Too many redirects"+ run cfg n = do+ res <- runWSApp cfg $ \conn -> do+ send conn routerBin+ r::WSChannelResult <- receive conn+ dbgS $ unwords ["Received CHATS answer",show r]+ case r of+ Failure why -> errIn why+ Success -> Right <$> app conn -- (Connection (receive conn) (send conn) (close conn))+ --Success -> Right <$> app (Connection (receive conn) (send conn) (close conn))+ RetryAt addr -> return (Left $ Config addr)+ case res of+ Left cfg' -> run cfg' (n+1)+ Right r -> return r+ errIn msg = dbg ["Failure",msg] >> error msg++-- |Send a value on a typed connection+send :: (Show a,Flat a) => WSConnection -> a -> IO ()+send conn v = do+ let e = flat v+ output conn e+ --dbg ["sent",show v,"as",show $ L.unpack e]++-- |Receive a value from a typed connection+receive :: (Show a,Flat a) => WSConnection -> IO a+receive conn = do+ e <- input conn+ either (\ex -> error $ unwords ["receive error",show ex]) return $ unflat e++-- receive :: Flat a => WSConnection -> IO (Maybe a)+-- receive conn = do+-- mbs <- input conn+-- return $ case mbs of+-- Nothing -> Nothing+-- Just bs -> eitherToMaybe $ unflat bs+-- -- |Setup a connection by sending a value specifying the routing protocol to be used+-- protocol :: (Show r, Model r, Flat r) => Connection ByteString -> r -> IO ()+-- --protocol = setProtocol (return ())+-- protocol conn routerType = do+-- dbg ["protocol",show routerType]+-- send conn . typedBLOB $ routerType+-- r::WSChannelResult <- receive conn+-- case r of+-- Failure why -> err $ T.unpack why+-- Success -> return ()+-- RetryAt addr -> err (show $ RetryAt addr)+-- where+-- err msg = error msg -- unwords ["Failed to establish connection:",msg]++-- setProtocol onSuccess onFailure conn router = do+-- dbg ["protocol",show router]+-- send conn . typedBLOB $ router+-- r::WSChannelResult <- receive conn+-- case r of+-- Failure why -> onFailure err $ T.unpack why+-- Success -> onSuccess --+-- RetryAt addr -> err (show $ RetryAt addr)+-- where+-- err msg = error msg -- unwords ["Failed to establish connection:",msg]++-- setProtocol conn routerType = run 1+-- where+-- run 4 = errIn "Too many redirects"+-- run n = do+-- dbg ["protocol",show routerType,"attempt",show n]+-- send conn . typedBLOB $ routerType+-- r::WSChannelResult <- receive conn+-- case r of+-- Failure why -> errIn (T.unpack why)+-- Success -> Right <$> app conn -- (Connection (receive conn) (send conn) (close conn))+-- --Success -> Right <$> app (Connection (receive conn) (send conn) (close conn))+-- RetryAt addr -> return (Left $ Config addr)+-- case res of+-- Left cfg' -> run cfg' (n+1)+-- Right r -> return r+-- errIn msg = dbg ["Failure",msg] >> error msg
+ src/Network/Top/Types.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif++module Network.Top.Types(+ -- *Top access point configuration+ Config(..),cfgIP,cfgPort,cfgPath,def++ -- *Connection Protocols+ --,byPattern+ ,ByPattern(..)+ ,ByType(..),byTypeRouter+ ,ByAny(..),byAny+ ,Echo(..)++ -- *Connection+ ,App+ ,Connection(..)+ ,inputWithTimeout++ -- *WebSocket Connection+ ,WSApp+ ,WSConnection+ ,chatsProtocol,chatsProtocolT++ -- *CHATS+ ,WSChannelResult+ ,ChannelSelectionResult(..)++ -- *Network Addresses+ ,WebSocketAddress(..),SocketAddress(..),IP4Address(..),IP6Address,HostAddress(..)++ -- *Re-exports+ -- ,module ZM+ -- ,B.ByteString+ ) where++import qualified Data.ByteString as B+import Data.Default.Class+import Data.List+import Data.Pattern.Types+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Word+import Network.Top.Util+import System.Timeout+import Text.PrettyPrint.HughesPJClass (text)+import ZM++#if __GLASGOW_HASKELL__ < 800+import Language.Haskell.TH.Lift+#else+import Language.Haskell.TH.Syntax (Lift) -- ,lift)+#endif++-- |Top's access point configuration+newtype Config = Config {accessPoint::WebSocketAddress IP4Address}++-- |Return Top's access point IP+cfgIP :: Config -> String+cfgIP = prettyShow . socketAddress . host . accessPoint++-- |Return Top's access point Port+cfgPort :: Config -> Int+cfgPort = fromIntegral . port . socketPort . host . accessPoint++-- |Return Top's access point Path+cfgPath :: Config -> String+cfgPath = path . accessPoint++-- |The configuration for the default Top router+instance Default Config where+ def = Config $ WebSocketAddress False (SocketAddress (DNSAddress "quid2.net") (HostPort 80)) "/ws"++---------------- Routing Protocols++-- |Return the value of the ByType router identifier for the given type+byTypeRouter :: Type AbsRef -> TypedBLOB+byTypeRouter t =+ let TypeApp f _ = absType (Proxy::Proxy (ByType ()))+ in typedBLOB_ (TypeApp f t) ByType++-- |Echo protocol: any value sent in is returned verbatim to the sender (useful for testing purposes)+-- Client can specify if received messages should be logged (for debugging purposes)+data Echo a = Echo { echoDebug :: Bool }+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (Echo a)++{-|+A routing protocol specified by a type.++Once a connection is established, clients:++ * can send messages of the given type++ * will receive all messages of the same type sent by other agents+-}+data ByType a = ByType+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (ByType a)++{-|+A routing protocol to receive all messages.++The ByAny type parameter indicates the type of the messages exchanged on the channel (usually:TypedBLOB).++Once a connection is established, clients:++ * can send messages of any type, as values of the ByAny type argument (for example: an Int value encoded as the corresponding TypedBLOB value)++ * will receive all messages sent by other agents+-}+data ByAny a = ByAny deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (ByAny a)++-- |Shortcut to specify+byAny :: ByAny TypedBLOB+byAny = ByAny :: ByAny TypedBLOB++---------- Connection++-- |An application that connects to a channel of type a and eventually returns an IO r+type App a r = Connection a -> IO r++-- |A typed bidirectional connection/channel+data Connection a = Connection {+ -- |Block read till a value is received+ input::IO a++ -- |Block write till a value is sent+ ,output::a -> IO ()++ -- |Close the connection+ ,close :: IO ()+ }++-- |Return a value received on the connection+-- or Nothing if no value is received in the specified number of seconds+--+-- NOTE: In case of timeout, the connection will be closed.+inputWithTimeout :: Int -> Connection a -> IO (Maybe a)+inputWithTimeout secs conn = timeout (seconds secs) (input conn)++---------- WebSocket Connection++-- |An application that connects to a WebSocket channel of type a and eventually returns an IO r+type WSApp r = App B.ByteString r++-- A typed connection+-- data Connection a = Connection WS.Connection++-- CHECK: use Input/Output from pipes-concurrency instead?+-- data WSConnection = WSConnection {sendMsg :: B.ByteString -> IO (),receiveMsg :: IO B.ByteString}+-- |A WebSocket connection+type WSConnection = Connection B.ByteString++-- data Connection a = Connection {+-- -- |Block read till a value is received+-- -- returns Nothing if the connection is closed+-- input::IO (Maybe a)++-- -- |Output a value+-- -- returns True if output succeeded, False otherwise+-- ,output::a -> IO Bool+-- }+++---------- CHATS protocol++type WSChannelResult = ChannelSelectionResult (WebSocketAddress IP4Address)++-- |The value returned by an access point, after receiving a routing channel setup request.+data ChannelSelectionResult addr =+ -- |The channel has been permanently setup to the requested+ -- protocol+ Success+ |+ -- |The access point is unable or unwilling to open a connection+ -- with the requested routing protocol+ Failure { reason :: String }+ |+ -- |User should retry with the same transport protocol at the+ -- indicated address+ RetryAt addr+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (ChannelSelectionResult a)++-- |CHATS binary identifier+chatsProtocol :: B.ByteString+chatsProtocol = encodeUtf8 chatsProtocolT++-- |CHATS textual identifier+chatsProtocolT :: T.Text+chatsProtocolT = "chats"++---------- Network Addresses++-- |The full address of a <https://en.wikipedia.org/wiki/WebSocket WebSocket> endpoint+data WebSocketAddress ip =+ WebSocketAddress+ {+ -- |True if the connection is wss (secure), False if is ws+ secure :: Bool+ -- |Host endpoint, example: SocketAddress (DNSAddress "quid2.net") (HostPort 80)+ , host :: SocketAddress ip+ -- |Path to the WebSocket access point, example: "/ws"+ , path :: String+ }+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model ip => Model (WebSocketAddress ip)++-- |The address of a <https://en.wikipedia.org/wiki/Network_socket network socket>+data SocketAddress ip = SocketAddress { socketAddress :: HostAddress ip, socketPort :: HostPort }+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model ip => Model (SocketAddress ip)++-- |A Sockets port (e.g. 80)+data HostPort = HostPort {port::Word16} deriving (Eq, Ord, Show, Generic,Flat,Model)++-- |A host address, either an IP or a DNS domain+data HostAddress ip = IPAddress ip+ | DNSAddress String+ deriving (Eq, Ord, Show, Generic, Flat)+instance Model ip => Model (HostAddress ip)++-- |An IP4 address+data IP4Address = IP4Address Word8 Word8 Word8 Word8 deriving (Eq, Ord, Show, Generic, Flat, Model)++-- |An IP6 address+data IP6Address = IP6Address Word16 Word16 Word16 Word16 Word16 Word16 Word16 Word16 deriving (Eq, Ord, Show, Generic, Flat, Model)++---------- Pretty instances+-- Easier to define here than in a separate file+instance Pretty IP4Address where+ pPrint (IP4Address w1 w2 w3 w4) = text . intercalate "." . map hex $ [w1, w2, w3, w4]++instance Pretty ip => Pretty (HostAddress ip) where+ pPrint (IPAddress ip) = pPrint ip+ pPrint (DNSAddress t) = text t+++-- Lift instances (needed by TH)+#if __GLASGOW_HASKELL__ < 800+--deriveLift ''ByPattern+--deriveLift ''Match+deriveLift ''Pat+-- deriveLift ''WildCard+deriveLift ''PRef+#else+-- deriving instance Lift a => Lift (ByPattern a)+--deriving instance Lift (ByPattern a)+--deriving instance Lift Match+-- deriving instance Lift a => Lift (Type a)+-- deriving instance Lift AbsRef+-- deriving instance Lift (SHA3_256_6 a)+deriving instance Lift a => Lift (Pat a)+-- deriving instance Lift WildCard+deriving instance Lift PRef+#endif++-- Call/Return protocol+-- data Call a = Call a CallBack+-- | Return CallBack a+-- type CallBack = [Word8]++-- instance Invariant Conn where+-- invmap _ _ ConnOpening = ConnOpening+-- invmap f g (ConnOpen i o) = ConnOpen (fmap f i) (o . g)+-- invmap _ _ ConnClosed = ConnClosed+++-- combine:: Connection a -> Connection b -> Connection (Either a b)+-- combine c1 c2 = Connection ci co+-- where+-- ci = do -- BAD: this blocks on the first connection+-- i1 <- input c1+-- case i1 of+-- Nothing -> (Right <$>) <$> input c2+-- Just v -> return . Just . Left $ v+-- co (Left a) = output c1 a+-- co (Right b) = output c2 b
+ src/Network/Top/Util.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Top.Util(+ -- *Exceptions+ strictTry,try,tryE,forceE,SomeException++ -- *Time+ ,milliseconds,seconds,minutes+ ,withTimeout++ -- *Threads+ ,async,cancel,threadDelay++ -- *Monads+ ,liftIO,forever,when,unless++ -- *Logging (with native ghcjs support)+ ,dbg,warn,info,err,dbgS,logLevel++#ifdef ghcjs_HOST_OS+ ,Priority(..)+#else+ ,logLevelOut+ ,module X+#endif++ -- *Other+ ,eitherToMaybe+++) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (async, cancel)+import Control.DeepSeq+import Control.Exception (SomeException, try)+import qualified Control.Exception as E+import Control.Monad+import Control.Monad.IO.Class+import GHC.IO.Handle (Handle)+import System.Timeout++---------- Logging++#ifdef ghcjs_HOST_OS++------------ GHC-JS Version+import Data.IORef+import System.IO.Unsafe+import qualified Data.JSString as S++foreign import javascript unsafe "console.log($1)" clog :: S.JSString -> IO ()++foreign import javascript unsafe "console.info($1)" cinfo :: S.JSString -> IO ()++foreign import javascript unsafe "console.warn($1)" cwarn :: S.JSString -> IO ()++foreign import javascript unsafe "console.error($1)" cerr :: S.JSString -> IO ()++data Priority = DEBUG | INFO | WARNING | ERROR deriving (Show,Eq,Ord)++gLogLevel :: IORef Priority+{-# NOINLINE gLogLevel #-}+gLogLevel = unsafePerformIO (newIORef DEBUG)++logLevel :: Priority -> IO ()+dbgS :: String -> IO ()+dbg :: [String] -> IO ()+info :: [String] -> IO ()+warn :: [String] -> IO ()+err :: [String] -> IO ()++logLevel = writeIORef gLogLevel++dbgS s = do+ l <- readIORef gLogLevel+ when (l == DEBUG) $ clog . S.pack $ s++dbg = dbgS . unwords++info ss = do+ l <- readIORef gLogLevel+ when (l <=INFO) $ cinfo . S.pack . unwords $ ss++warn ss = do+ l <- readIORef gLogLevel+ when (l <=WARNING) $ cwarn . S.pack . unwords $ ss++err = cerr . S.pack . unwords++#else+------------ GHC Version+import System.Log.Handler.Simple (verboseStreamHandler)+import System.Log.Logger as X++-- |Setup the global logging level+logLevel :: Priority -> IO ()+logLevel = updateGlobalLogger rootLoggerName . setLevel++logLevelOut :: Priority -> Handle -> IO ()+logLevelOut level handle = do+ out <- verboseStreamHandler handle level+ updateGlobalLogger rootLoggerName (setHandlers [out] . setLevel level)++-- |Log a message at DEBUG level+dbgS :: String -> IO ()+dbgS = debugM "top"++-- |Log multiple messages at DEBUG level+dbg :: MonadIO m => [String] -> m ()+dbg = liftIO . dbgS . unwords++-- |Log multiple messages at INFO level+info :: MonadIO m => [String] -> m ()+info = liftIO . infoM "top" . unwords++-- |Log multiple messages at WARNING level+warn :: MonadIO m => [String] -> m ()+warn = liftIO . warningM "top" . unwords++-- |Log multiple messages at ERROR level+err :: MonadIO m => [String] -> m ()+err = liftIO . errorM "top" . unwords++#endif++---------- Exceptions++-- |forceE == either error id+forceE :: Either String c -> c+forceE = either error id -- throwIO++-- |Like `try` but with returned exception fixed to `SomeException`+tryE :: IO a -> IO (Either SomeException a)+tryE = try++-- |Strict try, `deepseq`s the returned value+strictTry :: NFData a => IO a -> IO (Either E.SomeException a)+strictTry op = E.catch (op >>= \v -> return . Right $! deepseq v v) (\(err:: E.SomeException) -> return . Left $ err)++-- |Run an IO op with a timeout+withTimeout :: Int -- ^Timeout (in seconds)+ -> IO a -- ^Op to execute+ -> IO (Either String a) -- ^Right if op completed correctly, Left otherwise+-- withTimeout secs op = maybe (Left "Timeout") Right <$> timeout (seconds secs) op+withTimeout secs op = do+ em <- try $ timeout (seconds secs) op+ return $ case em of+ Left (e::SomeException) -> Left (show e)+ Right m -> maybe (Left "Timeout") Right m++-- |Convert an Either to a Maybe+eitherToMaybe :: Either t a -> Maybe a+eitherToMaybe (Right a) = Just a+eitherToMaybe (Left _) = Nothing++---------- Time++-- |Convert minutes to microseconds (μs)+minutes :: Num c => c -> c+minutes = seconds . (60*)++-- |Convert seconds to microseconds (μs)+seconds :: Num a => a -> a+seconds = (* 1000000)++-- |Convert milliseconds to microseconds (μs)+milliseconds :: Num a => a -> a+milliseconds = (* 1000)
+ src/Network/Top/WebSockets.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedFFITypes #-}++-- |WebSockets Connection (with GHCJS native support)+module Network.Top.WebSockets(+ runWSApp+ ) where++import qualified Data.ByteString as B+import Network.Top.Types++#ifdef ghcjs_HOST_OS+-- GHC-JS Version+import qualified Data.ByteString.Lazy as L+import Control.Applicative (Alternative (empty, (<|>)))+import Control.Exception+import qualified Control.Concurrent.STM as S+import qualified Data.JSString as S+import Data.Maybe+import GHCJS.Buffer+import qualified GHCJS.Buffer as Buffer+import GHCJS.Foreign+import GHCJS.Foreign.Internal+import GHCJS.Marshal+import GHCJS.Marshal.Pure+import GHCJS.Types+import JavaScript.Web.Blob.Internal (Blob, SomeBlob (..))+import JavaScript.Web.MessageEvent+import JavaScript.Web.WebSocket hiding (close)+import qualified JavaScript.Web.WebSocket as JS+import JavaScript.TypedArray.ArrayBuffer+import qualified JavaScript.TypedArray.ArrayBuffer as A+import GHC.Exts+import qualified Data.Text as T+import Network.Top.Util+-- import JavaScript.TypedArray -- ArrayBuffer, SomeArrayBuffer(..))+-- import JavaScript.TypedArray.Internal -- ArrayBuffer, SomeArrayBuffer(..))++runWSApp :: Config -> WSApp r -> IO r+runWSApp cfg = bracket (newConnection cfg) close++-- |A WS connection+data Conn a = Conn {connConfig:: Config+ ,connStatus :: S.TVar (ConnStatus a)+ ,connMessages :: S.TQueue a}++-- |Connection Status+data ConnStatus a = ConnOpening+ | ConnOpen {inp::IO a,out::a -> IO (),cls::IO ()}+ | ConnClosed -- is this needed?++newConnection :: Config -> IO WSConnection+newConnection cfg = do+ conn <- Conn cfg <$> S.newTVarIO ConnClosed <*> S.newTQueueIO++ -- BUG: reopen connection without sending the protocol+ -- return $ Connection+ -- (open conn >>= \(i,o,c) -> i)+ -- (\v -> open conn >>= \(i,o,c) -> o v)+ -- (tillClose $ connStatus conn)+ (i,o,c) <- open conn+ return $ Connection i o (tillClose $ connStatus conn)++ where+ tillClose st = do+ dbgS "[Close"+ toClose <- S.atomically $ do+ s <- S.readTVar st+ case s of+ ConnOpening -> S.retry+ ConnOpen _ _ cls -> return $ Just cls+ ConnClosed -> return Nothing++ fromMaybe (return ()) toClose+ dbgS "Close]"++-- changeStatus conn = S.atomically $ S.writeTVar (connStatus conn) ConnClosed++-- |Block till open+open c =+ fromMaybe <$> reopen c <*> (S.atomically $ do+ s <- S.readTVar (connStatus c)+ case s of+ ConnOpening -> S.retry+ ConnOpen i o c -> return $ Just (i,o,c)+ ConnClosed -> do+ S.writeTVar (connStatus c) ConnOpening+ return Nothing)++reopen c = do+ dbgS "[reopen"+ let cfg = connConfig c+ econn <- tryE (JS.connect $ JS.WebSocketRequest {+ url= S.pack $ concat ["ws://",cfgIP cfg,":",show (cfgPort cfg),cfgPath cfg]+ ,protocols=[S.pack $ T.unpack $ chatsProtocolT]+ ,onClose = Just $ \_ -> closeConn c+ ,onMessage = Just $ \event -> do+ dbgS "received message"+ case getDataFixed event of+ Left e -> error e+ Right bs -> S.atomically . S.writeTQueue (connMessages c) $ bs+ -- case getDataFixed event of+ -- StringData s -> dbgS "unexpected String message"+ -- BlobData blob -> dbgS "unexpected Blob message"+ -- ArrayBufferData ab -> S.atomically . S.writeTQueue (connMessages c) . L.fromStrict . toBS $ ab+ })++ case econn of+ Left e -> do+ dbgS "Error while opening connection"+ threadDelay (seconds 5)+ reopen c++ Right ws -> do+ let+ -- if there is data return it,+ -- otherwise if connection is open retry otherwise return Nothing+ -- inp = do+ -- mmsg <- S.atomically $+ -- ((Just <$> S.readTQueue (connMessages c))+ -- <|> (Do+ -- connClosed <- isClosed <$> S.readTVar (connStatus c)+ -- case st of+ -- ConnOpening -> retry+ -- ConnOpen -> retry+ -- ConnClosed -> return Nothing+ -- S.check connClosed+ -- return Nothing+ -- ))+ -- case mmsg of+ -- Nothing -> open c >> mmsg+ -- Just msg -> return msg+ inp = do+ r <- S.atomically $ S.readTQueue (connMessages c)+ -- dbg ["received",show $ L.unpack r]+ return r++ out v = do+ -- dbg ["send",show $ L.unpack v]+ webSocketSend ws v+ -- out v = do+ -- r <- tryE (webSocketSend conn (L.toStrict v))+ -- case r of+ -- Left err -> do+ -- cls (unwords ["websockets output failed",show err])+ -- (_,o,_) <- reopen c+ -- o v++ -- Right () -> return ()++ cls reason = do+ -- closeConn conn reason+ JS.close Nothing Nothing ws -- (S.pack "FIX THIS") ws+ dbg [reason,"closed]"]++ let cls' = (cls "user request")+ js_asArrayBuffer ws+ S.atomically $ S.writeTVar (connStatus c) (ConnOpen inp out cls')+ dbgS "reopen]"+ return (inp,out,cls')+ where+ closeConn conn = S.atomically $ S.writeTVar (connStatus conn) ConnClosed++-- closeConn conn reason = do+-- JS.close conn+-- dbg ["Closing connection",reason]++-- runWSApp :: Config -> WSApp r -> IO r+-- runWSApp cfg app = do+-- q <- S.newTQueueIO+-- closed <- S.newTVarIO False++-- let wsClose _ = close "WebSockets Close"++-- close reason = do+-- S.atomically (S.writeTVar closed True)+-- dbg ["connection closed",reason]++-- wsMessage e = do+-- dbgS "received message"+-- case getData e of+-- StringData s -> close "unexpected String message"+-- BlobData blob -> close "unexpected Blob message"+ -- ArrayBufferData ab -> S.atomically . S.writeTQueue q . L.fromStrict . toBS $ ab+ -- ArrayBufferData ab -> Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer $ ab+-- Conn <- JS.connect $ JS.WebSocketRequest {+-- url= S.pack $ concat ["ws://",ip cfg,":",show (port cfg),path cfg]+-- ,protocols=[S.pack "quid2.net"]+-- ,onClose=Just wsClose+-- ,onMessage=Just wsMessage}++-- let+-- out v = do+-- r <- tryE (webSocketSend conn (L.toStrict v))+-- case r of+-- Left err -> do+-- close (unwords ["websockets output failed",show err])+-- return False+-- Right () -> return True++-- -- if there is data return it,+-- -- otherwise if connection is open retry otherwise return Nothing+-- inp = S.atomically $+-- ((Just <$> S.readTQueue q)+-- <|> (do+-- connClosed <- S.readTVar closed+-- S.check connClosed+-- return Nothing+-- ))+-- app $ Connection inp out++ --putStrLn (show . L.unpack . flat . typedBytes $ (ByType::ByType Bool))+ -- putStrLn (show $ B.unpack . shake128 32 . B.pack $ [])+ -- app $ WSConnection {sendMsg = webSocketSend conn . L.toStrict+ -- ,receiveMsg = undefined}++-- printB :: B.ByteString -> IO ()+-- printB = print++toBS :: ArrayBuffer -> B.ByteString+toBS = Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer+-- toBS1 = Buffer.toByteString 0 Nothing++webSocketSend :: WebSocket -> B.ByteString -> IO ()+webSocketSend ws bs | B.length bs == 0 = return ()+ | otherwise = do+ let (b, off, len) = fromByteString bs+ -- dbgS $ unwords ["BUFFER OFF",show off,"LEN",show len]+ js_sendByteString ws (getArrayBuffer b) off len++foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal++getDataFixed :: MessageEvent -> Either String B.ByteString -- MessageEventData+getDataFixed me = case js_getData me of+ (# 1#, r #) -> Left "Unexpected String"+ (# 2#, r #) -> Left "Unexpected Blob"+ (# 3#, r #) -> Right $ toBS r+{-# INLINE getDataFixed #-}++foreign import javascript unsafe+ --"$1.send(new Uint8Array($2,$3,$4));$r=new Uint8Array($2,$3,$4).byteLength"+ "$1.send(new Uint8Array($2,$3,$4))"+ js_sendByteString :: WebSocket -> ArrayBuffer -> Int -> Int -> IO ()++foreign import javascript unsafe+ "$r2 = $1.data;$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 3 : 2)"+ js_getData :: MessageEvent -> (# Int#, ArrayBuffer #)++-- By default, websockets would be in blob mode, so we need this.+foreign import javascript unsafe+ "$1.binaryType='arraybuffer'"+ js_asArrayBuffer :: WebSocket -> IO ()++#else+------------ GHC Version+import qualified Network.WebSockets as WS++-- |Run a WebSockets Application, keep connection alive.+--+-- Automatically close sockets on WSApp exit+runWSApp ::+ Config -- ^ Top configuration+ -> WSApp a -- ^ Application to connect+ -> IO a -- ^ Value returned from the application+runWSApp cfg app =+ WS.runClientWith (cfgIP cfg) (cfgPort cfg) (cfgPath cfg) opts [("Sec-WebSocket-Protocol", chatsProtocol)] $ \conn -> do+ -- WS.forkPingThread conn 20 -- Keep connection alive avoiding timeouts (FIX: the server should send pings as this is required by browsers)+ --WS.sendClose conn (1000::Int)+ -- app $ Connection+ -- (eitherToMaybe <$> tryE (WS.receiveData conn))+ -- (\bs -> isRight <$> tryE (WS.sendBinaryData conn bs))+ app $ Connection+ (WS.receiveData conn)+ (WS.sendBinaryData conn)+ (WS.sendClose conn ("So long, and thanks for all the fish!"::B.ByteString))++ where+ opts = WS.defaultConnectionOptions -- { WS.connectionOnPong = dbgS "gotPong"}++-- -- |Send a raw binary message on a WebSocket (untyped) connection+-- sendMsg :: WS.Connection -> L.ByteString -> IO ()+-- sendMsg = WS.sendBinaryData++-- -- |Receive a raw binary message from a WebSocket (untyped) connection+-- receiveMsg :: WS.Connection -> IO L.ByteString+-- receiveMsg conn = WS.receiveData conn++#endif+
+ src/Repo/DB.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+-- |A persistent repository for absolute types, based on acid-state+module Repo.DB(DBState(..),wholeDB,openDB,closeDB,getDB,putDB) where++import "mtl" Control.Monad.Reader+import "mtl" Control.Monad.State+import Data.Acid+import qualified Data.Map as M+import Data.SafeCopy+import Data.Typeable+import System.FilePath+import ZM++type DB = AcidState DBState++newtype DBState = DBState AbsEnv+ deriving (Typeable,Show)++-- Transactions+whole :: Query DBState DBState+whole = ask++insert :: AbsRef -> AbsADT -> Update DBState ()+insert key value = modify (\(DBState st) -> DBState (M.insert key value st))++getByRef :: AbsRef -> Query DBState (Maybe AbsADT)+getByRef key = asks (\(DBState st) -> M.lookup key st)++makeAcidic ''DBState ['whole,'insert,'getByRef]++-- API+wholeDB :: DB -> IO DBState+wholeDB db = query db Whole++emptyDB :: DBState+emptyDB = DBState M.empty++openDB :: FilePath -> IO DB+openDB dir = do+ db <- openLocalStateFrom (dbDir dir) emptyDB+ -- wholeDB db >>= print+ createCheckpoint db+ return db++getDB :: DB -> AbsRef -> IO (Maybe AbsADT)+getDB db k = query db (GetByRef k)++putDB :: DB -> AbsRef -> AbsADT -> IO ()+putDB db k v = update db (Insert k v)++closeDB :: AcidState st -> IO ()+closeDB = closeAcidState++-- Utilities++dbDir :: FilePath -> FilePath+dbDir dir = dir </> "ADTS"++$(deriveSafeCopy 0 'base ''Type)+$(deriveSafeCopy 0 'base ''Identifier)+$(deriveSafeCopy 0 'base ''UnicodeSymbol)+$(deriveSafeCopy 0 'base ''UnicodeLetter)+$(deriveSafeCopy 0 'base ''UnicodeLetterOrNumberOrLine)+$(deriveSafeCopy 0 'base ''SHA3_256_6)+$(deriveSafeCopy 0 'base ''SHAKE128_48)+$(deriveSafeCopy 0 'base ''AbsRef)+$(deriveSafeCopy 0 'base ''ConTree)+$(deriveSafeCopy 0 'base ''ADTRef)+$(deriveSafeCopy 0 'base ''ADT)+$(deriveSafeCopy 0 'base ''NonEmptyList)+$(deriveSafeCopy 0 'base ''DBState)
+ src/Repo/Disk.hs view
@@ -0,0 +1,22 @@+-- |Persistent on-disk implementation of a repository of ZM types+module Repo.Disk(dbRepo) where++import Repo.DB+import qualified Repo.Types as R+import ZM++dbRepo :: FilePath -- ^Directory to store the repo (e.g. \"/tmp\")+ -> IO R.Repo -- ^A new repository+dbRepo dir = do+ db <- openDB dir+ return R.Repo {+ R.get = \ref -> do+ mr <- getDB db ref+ --print (unwords ["get",show ref,show mr])+ --dbg ["get",show ref,show $ isJust mr]+ return mr+ ,R.put = \adt -> do+ --dbg ["put",prettyShow adt]+ putDB db (absRef adt) adt+ ,R.close = closeDB db+ }
+ src/Repo/Memory.hs view
@@ -0,0 +1,22 @@+-- |Transient in-memory implementation of a repository of absolute types+module Repo.Memory(memRepo) where++import Data.IORef+import qualified Data.Map as M+import qualified Repo.Types as R+import ZM++-- |Returns a new repository+memRepo :: IO R.Repo+memRepo = do+ db <- newIORef M.empty+ return $ R.Repo {+ R.get = \ref -> do+ --dbg (unwords ["get",show ref])+ M.lookup ref <$> readIORef db+ ,R.put = \adt -> do+ --dbg (unwords ["put",prettyShow adt])+ modifyIORef db $ M.insert (absRef adt) adt+ ,R.close = return ()+ }+
+ src/Repo/Types.hs view
@@ -0,0 +1,8 @@+module Repo.Types (Repo(..)) where++import ZM++-- |A repository of absolute types+data Repo = Repo { get :: AbsRef -> IO (Maybe AbsADT)+ , put :: AbsADT -> IO ()+ , close :: IO () }
+ stack.yaml view
@@ -0,0 +1,11 @@+resolver: lts-6.32++packages:+- '.'++extra-deps:+- model-0.3+- flat-0.3+- zm-0.2.4+- cryptonite-0.22+- mono-traversable-1.0.2
+ stack710.yaml view
@@ -0,0 +1,11 @@+resolver: lts-6.32++packages:+- '.'++extra-deps:+- model-0.3+- flat-0.3+- zm-0.2.4+- cryptonite-0.22+- mono-traversable-1.0.2
+ stack801.yaml view
@@ -0,0 +1,11 @@+resolver: lts-7.23++packages:+- '.'++extra-deps:+- model-0.3+- flat-0.3+- zm-0.2.4+- cryptonite-0.22+- mono-traversable-1.0.2
+ stack802.yaml view
@@ -0,0 +1,11 @@+resolver: lts-8.15++packages:+- '.'++extra-deps:+- model-0.3+- flat-0.3+- zm-0.2.4+- cryptonite-0.22+- mono-traversable-1.0.2
+ test/DocSpec.hs view
@@ -0,0 +1,7 @@+module Main where+import Test.DocTest+import System.FilePath.Find++main :: IO ()+main = find always (extension ==? ".hs") "src" >>= doctest+
+ test/RepoSpec.hs view
@@ -0,0 +1,30 @@+import Control.Monad+import Network.Top.Repo+import Repo.Disk+import Repo.Memory+import qualified Repo.Types as R+import System.Directory+import Test.Tasty+import Test.Tasty.HUnit+import ZM++t = main++main = do++ mrepo <- memRepo+ drepo <- getTemporaryDirectory >>= dbRepo++ defaultMain $ testGroup "Repo" [+ testRepo mrepo+ ,testRepo drepo+ ]+ where+ testRepo repo = testCase "RepoTest" $ do+ let tm = absTypeModel (Proxy::Proxy Bool)+ let [tdef] = typeADTs tm+ R.put repo tdef+ tdef2 <- R.get repo (absRef tdef)+ when (Just tdef /= tdef2) $ assertFailure "ref not present"+ -- r <- ((tm ==) <$>) <$> solveType repo def (typeName tm)+ R.close repo
+ top.cabal view
@@ -0,0 +1,105 @@+name: top+version: 0.2+synopsis: Top (typed oriented protocol) API+description: See the <http://github.com/tittoassini/top online tutorial>.+homepage: http://github.com/tittoassini/top+category: Network+license: BSD3+license-file: LICENSE+author: Pasqualino `Titto` Assini+maintainer: tittoassini@gmail.com+copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini+cabal-version: >=1.10+build-type: Simple+Tested-With: GHC == 7.10.3 GHC == 8.0.1 GHC == 8.0.2+extra-source-files:+ stack.yaml+ stack710.yaml+ stack801.yaml+ stack802.yaml+ README.md++source-repository head+ type: git+ location: https://github.com/tittoassini/top++library+ + if impl(ghc <8)+ build-depends:+ th-lift >=0.7.7+ + if impl(ghcjs -any)+ build-depends:+ ghcjs-base >=0.2 && <0.3+ else+ exposed-modules:+ Repo.DB+ Repo.Disk+ build-depends:+ websockets >=0.9.8.2,+ hslogger >=1.2.10,+ acid-state >=0.14.2,+ safecopy >=0.9.3,+ filepath >=1.4.0.0+ exposed-modules:+ Data.Pattern+ Data.Pattern.Types+ Data.Pattern.TH+ Data.Pattern.Util+ Data.Pattern.Transform+ Network.Top+ Network.Top.Pipes+ Network.Top.Repo+ Network.Top.Types+ Network.Top.Run+ Network.Top.Util+ Network.Top.WebSockets+ Repo.Types+ Repo.Memory+ build-depends:+ async >=2.1.1,+ base >=4.7 && <5,+ bytestring >=0.10.6.0,+ data-default-class >=0.0.1,+ flat >=0.3,+ template-haskell >=2.10.0.0,+ pipes >=4.1.9,+ transformers >=0.4.2.0,+ zm >=0.2,+ text >=1.2.2.1,+ stm >=2.4.4.1,+ ListLike >=4.2.1,+ containers >=0.5.6.2,+ mtl >=2.2.1,+ deepseq >=1.4.1.1,+ extra >=1.4.10,+ time >=1.5.0.1,+ pretty >=1.1.2.0+ default-language: Haskell2010+ hs-source-dirs: src++test-suite top-test-repo+ type: exitcode-stdio-1.0+ main-is: RepoSpec.hs+ build-depends:+ base >=4.8.2.0,+ top >=0.1.1,+ zm >=0.2.4,+ tasty >=0.11.0.2,+ tasty-hunit >=0.9.2,+ directory >=1.2+ default-language: Haskell2010+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N++test-suite top-doctest+ type: exitcode-stdio-1.0+ main-is: DocSpec.hs+ build-depends:+ base >4 && <5,+ doctest >=0.11.1,+ filemanip >=0.3.6.3+ default-language: Haskell2010+ hs-source-dirs: test+ ghc-options: -threaded