gdritter repos cube-cotillion / a635b06
Basic working-ish library, needs cleaning up in lots of places Getty Ritter 7 years ago
7 changed file(s) with 243 addition(s) and 0 deletion(s). Collapse all Expand all
+4
-0
.gitignore less more
1 .cabal-sandbox
2 *~
3 dist
4 cabal.sandbox.config
+12
-0
LICENSE less more
1 Copyright (c) 2016, Getty Ritter
2 All rights reserved.
3
4 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5
6 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7
8 2. 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.
9
10 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11
12 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 HOLDER 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.
+146
-0
Network/CubeCotillion.hs less more
1 module Network.CubeCotillion where
2
3 import Control.Concurrent (forkIO)
4 import Control.Monad.IO.Class(MonadIO(..))
5 import Data.ByteString (ByteString)
6 import qualified Data.ByteString as BS
7 import Data.ByteString.Char8 (pack, unpack)
8 import GHC.Exts (IsString(..))
9 import MonadLib
10 import Network
11 import Network.SSH.Server
12
13 type Key = [ServerCredential]
14
15 loadKey = loadPrivateKeys
16
17 cubeCotillion :: Int -> Key -> CubeM () -> IO ()
18 cubeCotillion port keys cube = withSocketsDo $ do
19 let routes = getRoutes cube
20 sock <- listenOn (PortNumber (fromIntegral port))
21 let server = Server
22 { sAccept = mkHandlers sock routes
23 , sAuthenticationAlgs = keys
24 , sVersion = "CubeCotillion_0.0"
25 , sDebugLevel = 0
26 }
27 sshServer server
28
29 mkHandlers :: Socket -> [Route] -> IO (SessionHandlers, HandleLike)
30 mkHandlers sock routes = do
31 (handle, _, _) <- accept sock
32 let handlers = SessionHandlers
33 { cOpenShell = \ _ _ _ _ _ -> return False
34 , cDirectTcp = \ _ _ _ _ -> return False
35 , cRequestSubsystem = \ _ _ _ -> return False
36 , cAuthHandler = \ _ _ _ _ -> return AuthAccepted
37 , cRequestExec = \ cmd _ write -> do
38 _ <- forkIO $ do
39 case dispatchRoutes routes cmd of
40 Just action -> action write >> write Nothing
41 Nothing -> write Nothing
42 return True
43 }
44 return (handlers, handle2HandleLike handle)
45
46 cmd :: CommandPattern -> ActionM () -> CubeM ()
47 cmd command action = CubeM (put [Route command action])
48
49 bs :: ByteString -> ActionM ()
50 bs val = do
51 (_, write) <- ActionM ask
52 ActionM $ inBase $ write (Just val)
53
54 string :: String -> ActionM ()
55 string str = do
56 (_, write) <- ActionM ask
57 ActionM $ inBase $ write (Just (pack str))
58
59 param :: ByteString -> ActionM ByteString
60 param name = do
61 (vars, _) <- ActionM ask
62 let Just val = lookup name vars
63 return val
64
65 readParam :: Read a => ByteString -> ActionM a
66 readParam name = do
67 r <- param name
68 return (read (unpack r))
69
70 data Fragment
71 = Word ByteString
72 | Var ByteString
73 deriving (Eq, Show)
74
75 newtype CommandPattern = CommandPattern
76 { commandChunks :: [Fragment] } deriving (Eq, Show)
77
78 instance IsString CommandPattern where
79 fromString str =
80 CommandPattern
81 [ if BS.head c == 58
82 then Var (BS.tail c)
83 else Word c
84 | c <- BS.split 32 (pack str)
85 ]
86
87 match :: ByteString -> CommandPattern -> Maybe [(ByteString, ByteString)]
88 match bs cmd = go (BS.split 32 bs) (commandChunks cmd)
89 where go [] [] = Just []
90 go (b:bs) (Var t:ts) =
91 ((t, b):) `fmap` go bs ts
92 go (b:bs) (Word t:ts)
93 | b == t = go bs ts
94 | otherwise = Nothing
95 go _ _ = Nothing
96
97 data Route = Route
98 { routePattern :: CommandPattern
99 , routeAction :: ActionM ()
100 }
101
102 getRoutes :: CubeM () -> [Route]
103 getRoutes = snd . runId . runWriterT . runCubeM
104
105 dispatchRoutes :: [Route] -> ByteString -> Maybe (Writer -> IO ())
106 dispatchRoutes [] _ = Nothing
107 dispatchRoutes (r:rs) bs =
108 case match bs (routePattern r) of
109 Nothing -> dispatchRoutes rs bs
110 Just vs -> Just (runActionWith vs (routeAction r))
111
112 newtype CubeM a = CubeM
113 { runCubeM :: WriterT [Route] Id a }
114
115 instance Functor CubeM where
116 fmap f (CubeM x) = CubeM (fmap f x)
117
118 instance Applicative CubeM where
119 pure x = CubeM (pure x)
120 CubeM f <*> CubeM x = CubeM (f <*> x)
121
122 instance Monad CubeM where
123 CubeM x >>= f = CubeM (x >>= runCubeM . f)
124
125 type Env = [(ByteString, ByteString)]
126 type Writer = Maybe ByteString -> IO ()
127
128 newtype ActionM a = ActionM
129 { runActionM :: ReaderT (Env, Writer) IO a }
130
131 runActionWith :: Env -> ActionM () -> Writer -> IO ()
132 runActionWith env action writer =
133 runReaderT (env, writer) (runActionM action)
134
135 instance Functor ActionM where
136 fmap f (ActionM x) = ActionM (fmap f x)
137
138 instance Applicative ActionM where
139 pure x = ActionM (pure x)
140 ActionM f <*> ActionM x = ActionM (f <*> x)
141
142 instance Monad ActionM where
143 ActionM x >>= f = ActionM (x >>= runActionM . f)
144
145 instance MonadIO ActionM where
146 liftIO mote = ActionM (inBase mote)
+0
-0
README.md less more
(New empty file)
+42
-0
cube-cotillion.cabal less more
1 name: cube-cotillion
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter <gdritter@galois.com>
8 maintainer: Getty Ritter <gdritter@galois.com>
9 copyright: ©2016 Getty Ritter
10 category: Network
11 build-type: Simple
12 cabal-version: >= 1.12
13
14 flag build-example
15 description: Build example application
16 default: False
17
18 library
19 exposed-modules: Network.CubeCotillion
20 ghc-options: -Wall
21 build-depends: base >=4.7 && <4.9, bytestring, ssh-hans, monadLib, network, transformers
22 default-language: Haskell2010
23 default-extensions: OverloadedStrings,
24 ScopedTypeVariables
25
26 executable hello
27 if !flag(build-example)
28 buildable: False
29 main-is: hello.hs
30 hs-source-dirs: example
31 build-depends: base, cube-cotillion
32 default-language: Haskell2010
33 ghc-options: -threaded -rtsopts -with-rtsopts=-N
34
35 executable accumulator
36 if !flag(build-example)
37 buildable: False
38 main-is: accumulator.hs
39 hs-source-dirs: example
40 build-depends: base, cube-cotillion, transformers
41 default-language: Haskell2010
42 ghc-options: -threaded -rtsopts -with-rtsopts=-N
+23
-0
example/accumulator.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import Control.Monad.IO.Class (liftIO)
6 import Data.IORef
7 import Network.CubeCotillion
8
9 main :: IO ()
10 main = do
11 ref <- newIORef (0 :: Int)
12 pk <- loadKey "server-keys"
13 let action f = liftIO (modifyIORef ref f) >> bs "ok.\n"
14 cubeCotillion 9999 pk $ do
15 cmd "incr" $ action (+1)
16 cmd "decr" $ action (\ x -> x-1)
17 cmd "double" $ action (*2)
18 cmd "add :n" $ do
19 n <- readParam "n"
20 action (+n)
21 cmd "get" $ do
22 n <- liftIO $ readIORef ref
23 string (show n ++ "\n")
+16
-0
example/hello.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import Data.Monoid (mconcat)
6 import Network.CubeCotillion
7
8 main :: IO ()
9 main = do
10 key <- loadKey "server-keys"
11 cubeCotillion 8080 key $ do
12 cmd "greet" $ do
13 bs "Hello, world!\n"
14 cmd "greet :name" $ do
15 name <- param "name"
16 bs $ mconcat ["Hello, ", name, "!\n"]