diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/ConsoleCtrl.hs b/app/ConsoleCtrl.hs new file mode 100644 --- /dev/null +++ b/app/ConsoleCtrl.hs @@ -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 + diff --git a/app/WaiCtrl.hs b/app/WaiCtrl.hs new file mode 100644 --- /dev/null +++ b/app/WaiCtrl.hs @@ -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 + + diff --git a/app/WaiCutter.hs b/app/WaiCutter.hs new file mode 100644 --- /dev/null +++ b/app/WaiCutter.hs @@ -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) + + diff --git a/paprika.cabal b/paprika.cabal new file mode 100644 --- /dev/null +++ b/paprika.cabal @@ -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 diff --git a/src/System/Paprika.hs b/src/System/Paprika.hs new file mode 100644 --- /dev/null +++ b/src/System/Paprika.hs @@ -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 + + +