paprika (empty) → 0.1.0.0
raw patch · 7 files changed
+877/−0 lines, 7 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, bytestring, containers, distributed-process, file-embed, http-types, huckleberry, mtl, network-transport-inmemory, paprika, text, wai, wai-app-static, wai-websockets, warp, websockets, word8
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/ConsoleCtrl.hs +27/−0
- app/WaiCtrl.hs +266/−0
- app/WaiCutter.hs +350/−0
- paprika.cabal +81/−0
- src/System/Paprika.hs +121/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Takamasa Mitsuji (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 Takamasa Mitsuji 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/ConsoleCtrl.hs view
@@ -0,0 +1,27 @@+module Main where++import System.IO (hSetEcho,hSetBuffering,BufferMode(NoBuffering),stdin,stdout) +import System.Paprika++main :: IO ()+main = do+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ hSetEcho stdin False+ loop+ where+ loop = do+ ch <- getChar+ case ch of+ 'q' -> return ()+ _ -> do+ case ch of+ 's' -> stop+ 'f' -> forward+ 'b' -> backward+ 'l' -> forwardLeft+ 'r' -> forwardRight+ 't' -> turnRight+ _ -> return ()+ loop+
+ app/WaiCtrl.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Main where++import Data.String (fromString)+import System.Environment (getArgs)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai as Wai+import qualified Network.HTTP.Types as H+import qualified Network.Wai.Application.Static as Static+import Data.Maybe (fromJust)+import Data.FileEmbed (embedDir)+import WaiAppStatic.Types (toPieces)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.ByteString as BS++import Network.Transport.InMemory (createTransport)+import Control.Distributed.Process.Node (LocalNode,newLocalNode,initRemoteTable,forkProcess,runProcess)+import Control.Distributed.Process (Process,ProcessId,send,receiveWait,match,getSelfPid,terminate)+import Control.Monad (forever,mzero)+import Control.Monad.Trans (liftIO)+import Control.Concurrent (threadDelay)+import Control.Exception (catch)+import qualified Data.Set as Set++import Network.Wai.Handler.WebSockets (websocketsOr)+import qualified Network.WebSockets as WS+import Data.Word8 (_question)++import Data.Maybe(mapMaybe)+import GHC.Generics (Generic)+import Data.Typeable (Typeable)+import Data.Binary (Binary)++import Data.Aeson.Types (ToJSON,toJSON,object,(.=),FromJSON,(.:))+import qualified Data.Aeson as AE++import qualified System.Paprika as PP+++++main :: IO ()+main = do+ PP.stop+ PP.setLeftArm 0+ PP.setRightArm 0+ node <- createTransport >>= (\t -> newLocalNode t initRemoteTable)+ cmpid <- forkProcess node $ ctrlManagerProcess (Set.empty,CtrlCommandStop,(0,0))+ host:port:_ <- getArgs+ Warp.runSettings (+ Warp.setHost (fromString host) $+ Warp.setPort (read port) $+ Warp.defaultSettings+ ) $ websocketsOr WS.defaultConnectionOptions (wsRouterApp node cmpid) staticApp+++staticApp :: Wai.Application+staticApp = Static.staticApp $ settings { Static.ssIndices = indices }+ where+-- settings = Static.defaultWebAppSettings "static/ctrl"+ settings = Static.embeddedSettings $(embedDir "static/ctrl")+ indices = fromJust $ toPieces ["default.htm"] -- default content+++wsRouterApp :: LocalNode -> ProcessId -> WS.ServerApp+wsRouterApp node cmpid pconn+ | ("/default" == path) = ctrlApp node cmpid pconn+ | otherwise = WS.rejectRequest pconn "endpoint not found"+ where+ requestPath = WS.requestPath $ WS.pendingRequest pconn+ path = BS.takeWhile (/=_question) requestPath+++ctrlApp :: LocalNode -> ProcessId -> WS.ServerApp+ctrlApp node cmpid pconn = do+ conn <- WS.acceptRequest pconn+ WS.forkPingThread conn 30+ + cpid <- forkProcess node $ ctrlProcess conn+ runProcess node $ do+ send cmpid (CMMRegistCtrl cpid)+ send cmpid (CMMQueryCommand cpid)+ loop conn cpid `catch` onError cpid+ where+ loop :: WS.Connection -> ProcessId -> IO ()+ loop conn cpid = do+ msg <- WS.receive conn+ case msg of+ WS.ControlMessage (WS.Close _ _) -> onClose cpid++ WS.DataMessage (WS.Text lbs) -> do+ case AE.decode lbs :: Maybe CtrlManagerMsg of+ Nothing -> return ()+ Just cmd -> runProcess node $ send cmpid cmd+ loop conn cpid+ _ -> loop conn cpid+ + onError :: ProcessId -> WS.ConnectionException -> IO ()+ onError cpid _ = onClose cpid++ onClose cpid =+ runProcess node $ do+ send cmpid (CMMUnregistCtrl cpid)+ send cpid CMClose+ + requestPath = WS.requestPath $ WS.pendingRequest pconn+ query = BS.drop 1 $ BS.dropWhile (/=_question) requestPath+ name = T.unpack $ decodeUtf8 $ H.urlDecode True query+ ++++data CtrlCommand = CtrlCommandStop+ | CtrlCommandForward+ | CtrlCommandBackward+ | CtrlCommandForwardLeft+ | CtrlCommandForwardRight+ | CtrlCommandBackwardLeft+ | CtrlCommandBackwardRight+ | CtrlCommandTurnLeft+ | CtrlCommandTurnRight+ | CtrlCommandLeftArm PP.ArmLevel+ | CtrlCommandRightArm PP.ArmLevel+ deriving (Generic,Typeable)++instance Show CtrlCommand where+ show CtrlCommandStop = "s"+ show CtrlCommandForward = "f"+ show CtrlCommandBackward = "b"+ show CtrlCommandForwardLeft = "fl"+ show CtrlCommandForwardRight = "fr"+ show CtrlCommandBackwardLeft = "bl"+ show CtrlCommandBackwardRight = "br"+ show CtrlCommandTurnLeft = "tl"+ show CtrlCommandTurnRight = "tr"+ show (CtrlCommandLeftArm _) = "al"+ show (CtrlCommandRightArm _) = "ar"++instance Read CtrlCommand where+ readsPrec _ = mapMaybe t' <$> lex+ where+ t' :: (String,String) -> Maybe (CtrlCommand,String)+ t' (p,r) = t p >>= (\p' -> return (p',r))+ + t :: String -> Maybe CtrlCommand+ t s = case s of+ "s" -> Just CtrlCommandStop+ "f" -> Just CtrlCommandForward+ "b" -> Just CtrlCommandBackward + "fl" -> Just CtrlCommandForwardLeft+ "fr" -> Just CtrlCommandForwardRight+ "bl" -> Just CtrlCommandBackwardLeft+ "br" -> Just CtrlCommandBackwardRight+ "tl" -> Just CtrlCommandTurnLeft+ "tr" -> Just CtrlCommandTurnRight+ _ -> Nothing++instance Binary CtrlCommand++instance FromJSON CtrlCommand where+ parseJSON (AE.String s) = return $ read $ T.unpack s+ parseJSON (AE.Object o) = do+ cmd <- T.unpack <$> o .: "name"+ case cmd of+ "al" -> CtrlCommandLeftArm <$> o .: "level"+ "ar" -> CtrlCommandRightArm <$> o .: "level"+ + parseJSON _ = mzero+++type CtrlManagerState = (Set.Set ProcessId,CtrlCommand,(PP.ArmLevel,PP.ArmLevel))++data CtrlManagerMsg = CMMRegistCtrl ProcessId+ | CMMUnregistCtrl ProcessId+ | CMMSetCommand CtrlCommand+ | CMMQueryCommand ProcessId+ deriving (Show,Generic,Typeable)+ +instance Binary CtrlManagerMsg++instance FromJSON CtrlManagerMsg where+ parseJSON v@(AE.Object o) = do+ cmd <- T.unpack <$> o .: "name"+ case cmd of+ "al" -> CMMSetCommand <$> AE.parseJSON v+ "ar" -> CMMSetCommand <$> AE.parseJSON v+ otherwise -> CMMSetCommand <$> o .: "name"+ + parseJSON _ = mzero+ ++ctrlManagerProcess :: CtrlManagerState -> Process ()+ctrlManagerProcess state = do+ state' <- receiveWait [match (p state)]+ ctrlManagerProcess state'+ where+ p :: CtrlManagerState -> CtrlManagerMsg -> Process CtrlManagerState+ + p (cs,cmd,arm) (CMMRegistCtrl cpid) = return $ (Set.insert cpid cs,cmd,arm)+ + p (cs,cmd,arm) (CMMUnregistCtrl cpid) = return $ (Set.delete cpid cs,cmd,arm)+ + p (cs,cmd,(_,ar)) (CMMSetCommand cmd'@(CtrlCommandLeftArm lev)) = do+ liftIO $ PP.setLeftArm lev+ mapM_ (\pid -> send pid $ CMCommand cmd') $ Set.toList cs+ return $ (cs,cmd,(lev,ar))+ + p (cs,cmd,(al,_)) (CMMSetCommand cmd'@(CtrlCommandRightArm lev)) = do+ liftIO $ PP.setRightArm lev+ mapM_ (\pid -> send pid $ CMCommand cmd') $ Set.toList cs+ return $ (cs,cmd,(al,lev))+ + p (cs,_,arm) (CMMSetCommand cmd) = do+ case cmd of+ CtrlCommandStop -> liftIO PP.stop+ CtrlCommandForward -> liftIO PP.forward+ CtrlCommandBackward -> liftIO PP.backward+ CtrlCommandForwardLeft -> liftIO PP.forwardLeft+ CtrlCommandForwardRight -> liftIO PP.forwardRight+ CtrlCommandBackwardLeft -> liftIO PP.backwardLeft+ CtrlCommandBackwardRight -> liftIO PP.backwardRight+ CtrlCommandTurnLeft -> liftIO PP.turnLeft+ CtrlCommandTurnRight -> liftIO PP.turnRight+ mapM_ (\pid -> send pid $ CMCommand cmd) $ Set.toList cs+ return $ (cs,cmd,arm)+ + p state@(cs,cmd,(al,ar)) (CMMQueryCommand cpid) = do+ send cpid $ CMCommand cmd+ send cpid $ CMCommand $ CtrlCommandLeftArm al+ send cpid $ CMCommand $ CtrlCommandRightArm ar+ return state+ + + +data CtrlMsg = CMCommand CtrlCommand+ | CMClose+ deriving (Show,Generic,Typeable)+ +instance Binary CtrlMsg++instance ToJSON CtrlMsg where+ toJSON (CMCommand cmd@(CtrlCommandLeftArm lev)) =+ object ["type" .= ("command" :: String), "name" .= show cmd, "level" .= lev]+ + toJSON (CMCommand cmd@(CtrlCommandRightArm lev)) =+ object ["type" .= ("command" :: String), "name" .= show cmd, "level" .= lev ]+ + toJSON (CMCommand cmd) =+ object ["type" .= ("command" :: String), "name" .= show cmd ]++ctrlProcess :: WS.Connection -> Process () +ctrlProcess conn = forever $ receiveWait [match (p conn)]+ where+ p :: WS.Connection -> CtrlMsg -> Process ()+ + p conn msg@(CMCommand _ ) = liftIO $ WS.sendTextData conn $ AE.encode msg++ p conn CMClose = terminate ++
+ app/WaiCutter.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Main where++import Data.String (fromString)+import System.Environment (getArgs)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai as Wai+import qualified Network.HTTP.Types as H+import qualified Network.Wai.Application.Static as Static+import Data.Maybe (fromJust)+import Data.FileEmbed (embedDir)+import WaiAppStatic.Types (toPieces)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.ByteString as BS++import Network.Transport.InMemory (createTransport)+import Control.Distributed.Process.Node (LocalNode,newLocalNode,initRemoteTable,forkProcess,runProcess)+import Control.Distributed.Process (Process,ProcessId,send,receiveWait,match,getSelfPid,terminate)+import Control.Monad (forever)+import Control.Monad.Trans (liftIO)+import Control.Concurrent (threadDelay)+import Control.Exception (catch)+import qualified Data.Set as Set++import Network.Wai.Handler.WebSockets (websocketsOr)+import qualified Network.WebSockets as WS+import Data.Word8 (_question)++import GHC.Generics (Generic)+import Data.Typeable (Typeable)+import Data.Binary (Binary)++import Data.Aeson.Types (ToJSON,toJSON,object,(.=))+import qualified Data.Aeson as AE++import System.Paprika(leftOn,leftOff,rightOn,rightOff)+++++main :: IO ()+main = do+ node <- createTransport >>= (\t -> newLocalNode t initRemoteTable)+ vmpid <- forkProcess node $ viewerManagerProcess Set.empty+ rmpid <- forkProcess node $ reporterManagerProcess (RMS ([],[]) (Set.empty,Set.empty) 10) vmpid+ _ <- forkProcess node $ timerProcess rmpid+ host:port:_ <- getArgs+ Warp.runSettings (+ Warp.setHost (fromString host) $+ Warp.setPort (read port) $+ Warp.defaultSettings+ ) $ websocketsOr WS.defaultConnectionOptions (wsRouterApp node vmpid rmpid) staticApp+++staticApp :: Wai.Application+staticApp = Static.staticApp $ settings { Static.ssIndices = indices }+ where+-- settings = Static.defaultWebAppSettings "static/cutter"+ settings = Static.embeddedSettings $(embedDir "static/cutter")+ indices = fromJust $ toPieces ["viewer.htm"] -- default content+++wsRouterApp :: LocalNode -> ProcessId -> ProcessId -> WS.ServerApp+wsRouterApp node vmpid rmpid pconn+ | ("/viewer" == path) = viewerApp node vmpid rmpid pconn+ | ("/reporter" == path) = reporterApp node rmpid pconn+ | otherwise = WS.rejectRequest pconn "endpoint not found"+ where+ requestPath = WS.requestPath $ WS.pendingRequest pconn+ path = BS.takeWhile (/=_question) requestPath+++viewerApp :: LocalNode -> ProcessId -> ProcessId -> WS.ServerApp+viewerApp node vmpid rmpid pconn = do+ conn <- WS.acceptRequest pconn+ WS.forkPingThread conn 30+ + vpid <- forkProcess node $ viewerProcess conn+ runProcess node $ do+ send vmpid (VMMRegistViewer vpid)+ send rmpid (RMMQueryMembers vpid)+ send rmpid (RMMQueryThreshold vpid)+ loop conn vpid `catch` onError vpid+ where+ loop :: WS.Connection -> ProcessId -> IO ()+ loop conn vpid = do+ msg <- WS.receive conn+ case msg of+ WS.ControlMessage (WS.Close _ _) -> onClose vpid++ WS.DataMessage (WS.Text lbs) -> do+ let thr = read $ T.unpack $ WS.fromLazyByteString lbs+ runProcess node $ send rmpid $ RMMSetThreshold thr+ loop conn vpid+ _ -> loop conn vpid+ + onError :: ProcessId -> WS.ConnectionException -> IO ()+ onError vpid _ = onClose vpid++ onClose vpid =+ runProcess node $ do+ send vmpid (VMMUnregistViewer vpid)+ send vpid VMClose+ + requestPath = WS.requestPath $ WS.pendingRequest pconn+ query = BS.drop 1 $ BS.dropWhile (/=_question) requestPath+ name = T.unpack $ decodeUtf8 $ H.urlDecode True query+ +++reporterApp :: LocalNode -> ProcessId -> WS.ServerApp+reporterApp node rmpid pconn = do+ conn <- WS.acceptRequest pconn+ WS.forkPingThread conn 30+ + rpid <- forkProcess node $ reporterProcess conn+ runProcess node $ send rmpid (RMMRegistReporter rpid)+ loop conn rpid `catch` onError rpid+ where+ loop :: WS.Connection -> ProcessId -> IO ()+ loop conn rpid = do+ msg <- WS.receive conn+ case msg of+ WS.ControlMessage (WS.Close _ _) -> onClose rpid+ + WS.DataMessage (WS.Text _) -> do+ runProcess node $ send rmpid $ RMMCountUp rpid+ loop conn rpid+ _ -> loop conn rpid+ + onError :: ProcessId -> WS.ConnectionException -> IO ()+ onError rpid _ = onClose rpid+ + onClose rpid = + runProcess node $ do+ send rmpid (RMMUnregistReporter rpid)+ send rpid RMClose+ + requestPath = WS.requestPath $ WS.pendingRequest pconn+ query = BS.drop 1 $ BS.dropWhile (/=_question) requestPath+ name = T.unpack $ decodeUtf8 $ H.urlDecode True query +++++type ViewerManagerState = Set.Set ProcessId++data ViewerManagerMsg = VMMRegistViewer ProcessId+ | VMMUnregistViewer ProcessId+ | VMMFreq Int Int+ | VMMMembers Int Int+ | VMMThreshold Int+ deriving (Show,Generic,Typeable)+ +instance Binary ViewerManagerMsg++viewerManagerProcess :: ViewerManagerState -> Process ()+viewerManagerProcess state = do+ state' <- receiveWait [match (p state)]+ viewerManagerProcess state'+ where+ p :: ViewerManagerState -> ViewerManagerMsg -> Process ViewerManagerState+ + p state (VMMRegistViewer pid) = return $ Set.insert pid state+ + p state (VMMUnregistViewer pid) = return $ Set.delete pid state+ + p state (VMMFreq lf rf) = do+ mapM_ (\pid -> send pid $ VMFreq lf rf) $ Set.toList state+ return state+ + p state (VMMMembers lm rm) = do+ mapM_ (\pid -> send pid $ VMMembers lm rm) $ Set.toList state+ return state++ p state (VMMThreshold thr) = do+ mapM_ (\pid -> send pid $ VMThreshold thr) $ Set.toList state+ return state++++data ViewerMsg = VMFreq Int Int+ | VMMembers Int Int+ | VMThreshold Int+ | VMClose+ deriving (Show,Generic,Typeable)+ +instance Binary ViewerMsg++instance ToJSON ViewerMsg where+ toJSON (VMFreq lf rf) =+ object ["type" .= ("freq" :: String)+ ,"content" .= object ["left" .= lf+ ,"right" .= rf+ ]+ ]+ + toJSON (VMMembers lm rm) =+ object ["type" .= ("members" :: String)+ ,"content" .= object ["left" .= lm+ ,"right" .= rm+ ]+ ]++ toJSON (VMThreshold thr) =+ object ["type" .= ("threshold" :: String)+ ,"content" .= thr+ ]++viewerProcess :: WS.Connection -> Process () +viewerProcess conn = forever $ receiveWait [match (p conn)]+ where+ p :: WS.Connection -> ViewerMsg -> Process ()+ + p conn msg@(VMFreq _ _) = liftIO $ WS.sendTextData conn $ AE.encode msg+ + p conn msg@(VMMembers _ _) = liftIO $ WS.sendTextData conn $ AE.encode msg++ p conn msg@(VMThreshold _ ) = liftIO $ WS.sendTextData conn $ AE.encode msg++ p conn VMClose = terminate ++++data ReporterManagerState = RMS ([Int],[Int]) (Set.Set ProcessId, Set.Set ProcessId) Int++data ReporterManagerMsg = RMMRegistReporter ProcessId+ | RMMUnregistReporter ProcessId+ | RMMCountUp ProcessId+ | RMMQueryMembers ProcessId+ | RMMSetThreshold Int+ | RMMQueryThreshold ProcessId+ | RMMRequestAggregate+ | RMMRequestFreq+ deriving (Show,Generic,Typeable)+ +instance Binary ReporterManagerMsg+ +reporterManagerProcess :: ReporterManagerState -> ProcessId -> Process ()+reporterManagerProcess state vmpid = do+ state' <- receiveWait [match (p state)]+ reporterManagerProcess state' vmpid+ where+ p :: ReporterManagerState -> ReporterManagerMsg -> Process ReporterManagerState+ + p (RMS cs (lms,rms) thr) (RMMRegistReporter rpid) =+ if Set.size lms < Set.size rms+ then do+ let lms' = Set.insert rpid lms+ send rpid $ RMIsLeft True+ send vmpid $ VMMMembers (Set.size lms') (Set.size rms)+ return $ RMS cs (lms',rms) thr+ else do+ let rms' = Set.insert rpid rms+ send rpid $ RMIsLeft False+ send vmpid $ VMMMembers (Set.size lms) (Set.size rms')+ return $ RMS cs (lms,rms') thr+ + p (RMS cs (lms,rms) thr) (RMMUnregistReporter rpid) =+ if Set.member rpid lms+ then do+ let lms' = Set.delete rpid lms+ send vmpid $ VMMMembers (Set.size lms') (Set.size rms)+ return $ RMS cs (lms',rms) thr+ else do+ let rms' = Set.delete rpid rms+ send vmpid $ VMMMembers (Set.size lms) (Set.size rms')+ return $ RMS cs (lms,rms') thr+ + p (RMS (lcs,rcs) ms@(lms,_) thr) (RMMCountUp rpid) =+ if Set.member rpid lms+ then return $ RMS (head lcs +1 : tail lcs, rcs) ms thr+ else return $ RMS (lcs, head rcs +1 : tail rcs) ms thr+ + p state@(RMS _ (lms,rms) _) (RMMQueryMembers vpid) = do+ send vpid $ VMMembers (Set.size lms) (Set.size rms)+ return state+ + p (RMS cs ms _) (RMMSetThreshold thr) = do+ send vmpid $ VMMThreshold thr+ return $ RMS cs ms thr++ p state@(RMS _ _ thr) (RMMQueryThreshold vpid) = do+ send vpid $ VMThreshold thr+ return state+ + p (RMS (lcs,rcs) ms thr) RMMRequestAggregate = do+ -- [TODO] calc correct interbal+ return $ RMS (0 : take 10 lcs,0: take 10 rcs) ms thr+ + p state@(RMS (lcs,rcs) _ thr) RMMRequestFreq = do+ -- [TODO] calc correct interbal+ let lf = sum lcs+ let rf = sum rcs+ if thr <= lf+ then liftIO leftOn+ else liftIO leftOff+ if thr <= rf+ then liftIO rightOn+ else liftIO rightOff+ send vmpid $ VMMFreq lf rf+ return state++ ++++data ReporterMsg = RMIsLeft Bool+ | RMClose+ deriving (Show,Generic,Typeable)+ +instance Binary ReporterMsg++instance ToJSON ReporterMsg where+ toJSON (RMIsLeft True) =+ object ["type" .= ("side" :: String), "content" .= ("left" :: String)]+ + toJSON (RMIsLeft False) =+ object ["type" .= ("side" :: String), "content" .= ("right" :: String)]++reporterProcess :: WS.Connection -> Process () +reporterProcess conn = forever $ receiveWait [match (p conn)]+ where+ p :: WS.Connection -> ReporterMsg -> Process ()+ + p conn msg@(RMIsLeft _) = liftIO $ WS.sendTextData conn $ AE.encode msg++ p conn RMClose = terminate -- [TODO] RMMUnregistReporter++++timerProcess :: ProcessId -> Process ()+timerProcess rmpid = loop 0+ where+ loop :: Int -> Process ()+ loop i = do+ send rmpid $ RMMRequestAggregate+ if i `mod` 5 == 0+ then send rmpid $ RMMRequestFreq+ else return ()+ liftIO $ threadDelay $ 100 * 1000+ loop (i+1)++
+ paprika.cabal view
@@ -0,0 +1,81 @@+name: paprika+version: 0.1.0.0+synopsis: The Haskell library and examples for the kids programming robot paprika+description: Please see README.md+homepage: https://github.com/mitsuji/paprika#readme+license: BSD3+license-file: LICENSE+author: Takamasa Mitsuji+maintainer: tkms@mitsuji.org+copyright: 2016 Takamasa Mitsuji+category: System+build-type: Simple+cabal-version: >=1.10+-- extra-source-files:++library+ hs-source-dirs: src+ exposed-modules: System.Paprika+ build-depends: base >= 4.7 && < 5+ , huckleberry+ default-language: Haskell2010++executable paprika-console-ctrl-exe+ hs-source-dirs: app+ main-is: ConsoleCtrl.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , paprika+ default-language: Haskell2010++executable paprika-wai-ctrl-exe+ hs-source-dirs: app+ main-is: WaiCtrl.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , paprika+ , distributed-process+ , network-transport-inmemory+ , text+ , bytestring+ , file-embed+ , http-types+ , warp+ , wai+ , wai-app-static+ , wai-websockets+ , websockets+ , mtl+ , containers+ , word8+ , binary+ , aeson+ default-language: Haskell2010++executable paprika-wai-cutter-exe+ hs-source-dirs: app+ main-is: WaiCutter.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , paprika+ , distributed-process+ , network-transport-inmemory+ , text+ , bytestring+ , file-embed+ , http-types+ , warp+ , wai+ , wai-app-static+ , wai-websockets+ , websockets+ , mtl+ , containers+ , word8+ , binary+ , aeson+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mitsuji/paprika
+ src/System/Paprika.hs view
@@ -0,0 +1,121 @@+module System.Paprika (+ leftOn+ ,leftOff+ ,leftReverse+ ,rightOn+ ,rightOff+ ,rightReverse+ ,forward+ ,stop+ ,backward+ ,forwardLeft+ ,forwardRight+ ,backwardLeft+ ,backwardRight+ ,turnLeft+ ,turnRight+ ,ArmLevel+ ,setLeftArm+ ,setRightArm+ ) where++import qualified System.PIO.Linux.GPIO as GPIO+import qualified System.PIO.Linux.PWM as PWM+import Control.Concurrent (threadDelay)+import Prelude hiding ((!!),(||),(&&))+++{-++$ sh/setup_paprika.sh++[J18-pin1 ] <==> [1.8V <=> 3.3V] <==> [out3]+[J17-pin1 ] <==> [1.8V <=> 3.3V] <==> [out4]++[J20-pin11] <==> [out6]+[J20-pin12] <==> [out5]+[J20-pin13] <==> [out1]+[J20-pin14] <==> [out2]++-}+++leftOn = GPIO.setValue 78 True >> GPIO.setValue 79 False+leftOff = GPIO.setValue 78 False >> GPIO.setValue 79 False+leftReverse = GPIO.setValue 78 False >> GPIO.setValue 79 True++rightOn = GPIO.setValue 80 True >> GPIO.setValue 81 False+rightOff = GPIO.setValue 80 False >> GPIO.setValue 81 False+rightReverse = GPIO.setValue 80 False >> GPIO.setValue 81 True+++stop = leftOff >> rightOff++forward = leftOn >> rightOn+backward = leftReverse >> rightReverse++forwardLeft = leftOff >> rightOn+forwardRight = leftOn >> rightOff++backwardLeft = leftOff >> rightReverse+backwardRight = leftReverse >> rightOff++turnLeft = leftReverse >> rightOn+turnRight = leftOn >> rightReverse+++stop' n = stop >> threadDelay (n * 1000)++forward' n = forward >> threadDelay (n * 1000)+backward' n = backward >> threadDelay (n * 1000)++forwardLeft' n = forwardLeft >> threadDelay (n * 1000)+forwardRight' n = forwardRight >> threadDelay (n * 1000)++backwardLeft' n = backwardLeft >> threadDelay (n * 1000)+backwardRight' n = backwardRight >> threadDelay (n * 1000)++turnLeft' n = turnLeft >> threadDelay (n * 1000)+turnRight' n = turnRight >> threadDelay (n * 1000)++++(!!) p n = p >> stop' n++(||) p n = p >> forward' n+(&&) p n = p >> backward' n++(!|) p n = p >> forwardLeft' n+(|!) p n = p >> forwardRight' n++(!&) p n = p >> backwardLeft' n+(&!) p n = p >> backwardRight' n++(&|) p n = p >> turnLeft' n+(|&) p n = p >> turnRight' n+++type ArmLevel = Int++setLeftArm :: ArmLevel -> IO ()+setLeftArm lev+ | lev == 1 = PWM.setValue 1 20000000 320000+ | lev == -1 = PWM.setValue 1 20000000 2352000+ | otherwise = PWM.setValue 1 20000000 1300000+ +setRightArm :: ArmLevel -> IO ()+setRightArm lev+ | lev == 1 = PWM.setValue 2 20000000 2352000+ | lev == -1 = PWM.setValue 2 20000000 320000+ | otherwise = PWM.setValue 2 20000000 1300000+ ++test1 = forward' 2000 >> stop' 2000 >> forward' 2000 >> backward' 2000+ >> forwardLeft' 2000 >> forwardRight' 2000+ >> backwardLeft' 2000 >> backwardRight' 2000+ >> turnLeft' 2000 >> turnRight' 2000 >> stop+ +test2 = return () || 2000 !! 2000 || 2000 && 2000 !| 2000 |! 2000 !& 2000 &! 2000 &| 2000 |& 2000 !! 0+++