halvm-web (empty) → 0.3.0.0
raw patch · 5 files changed
+332/−0 lines, 5 filesdep +HALVMCoredep +HTTPdep +XenDevicesetup-changed
Dependencies added: HALVMCore, HTTP, XenDevice, async, base, bytestring, cereal, containers, hans, mime-types, network-uri, simple-tar, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- halvm-web.cabal +34/−0
- src/Main.hs +225/−0
- src/Network/HTTP/Streams.hs +41/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Adam Wick++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 Adam Wick 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
+ halvm-web.cabal view
@@ -0,0 +1,34 @@+name: halvm-web+version: 0.3.0.0+synopsis: A simple, static HaLVM web server+description: A simple, static HaLVM web server+homepage: http://halvm.org+license: BSD3+license-file: LICENSE+author: Adam Wick+maintainer: awick@galois.com+copyright: 2016, Adam Wick+category: Web+build-type: Simple+cabal-version: >=1.10++executable halvm-web+ main-is: Main.hs+ other-modules: Network.HTTP.Streams+ other-extensions: MultiWayIf+ build-depends: async >= 2.1.0 && < 2.3.0,+ base >= 4.7 && < 4.8,+ bytestring >= 0.10.4 && < 0.12.0,+ cereal >= 0.5.3 && < 0.8,+ containers >= 0.5.5.1 && < 0.8,+ HALVMCore >= 2.0.0 && < 2.2.0,+ hans >= 3.0.1 && < 3.4.0,+ HTTP >= 4000.3.3 && < 4002.0.0,+ mime-types >= 0.1.0.7 && < 0.4,+ network-uri >= 2.6.1.0 && < 2.9,+ simple-tar >= 0.5 && < 0.9,+ text >= 1.2.2.1 && < 1.5,+ XenDevice >= 2.0.0 && < 2.2.0+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010
+ src/Main.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+import Codec.Archive.Tar(Archive, ArchiveMember(..), unarchive,+ regContents, linkTarget)+import Control.Concurrent(threadDelay, forkIO)+import Control.Concurrent.Async(Async, async, waitAny)+import Control.Exception(SomeException, handle)+import Control.Monad(void, forever, forM_, foldM)+import qualified Data.ByteString as S+import Data.ByteString(ByteString)+import qualified Data.ByteString.Char8 as C+import Data.ByteString.Unsafe(unsafePackCStringLen)+import Data.Char(toLower)+import qualified Data.Map.Strict as Map+import Data.Serialize.Get(runGet, getWord32host)+import Data.Text(pack, unpack)+import Data.Text.Encoding(decodeUtf8)+import Foreign.Ptr(castPtr, nullPtr)+import Hans(newNetworkStack, addDevice, startDevice, processPackets,+ defaultConfig)+import Hans.Device(Device(..), listDevices, defaultDeviceConfig)+import Hans.IP4.Packet(IP4, showIP4)+import Hans.IP4.Dhcp.Client(DhcpLease(..), DhcpConfig(..), dhcpClient,+ defaultDhcpConfig)+import Hans.Addr(NetworkAddr, toAddr, showAddr)+import Hans.Lens(view)+import Hans.Socket(TcpListenSocket, sListen, sAccept,+ tcpRemoteAddr, defaultSocketConfig)+import Hypervisor.Console(Console, initXenConsole, writeConsole)+import Hypervisor.DomainInfo(domainModuleStart, domainModuleLength,+ DomainFlags(..), domainFlags)+import Hypervisor.XenStore(initXenStore)+import Network.HTTP(Request(..), Response(..), ResponseCode)+import Network.HTTP.Headers(HeaderName(..), retrieveHeaders, mkHeader,+ hdrValue)+import Network.HTTP.Stream(Stream(..), receiveHTTP, respondHTTP)+import Network.HTTP.Streams()+import Network.Mime(mimeByExt, defaultMimeMap, defaultMimeType)+import Network.URI(URI(..))++main :: IO ()+main =+ do con <- initXenConsole+ handle (handleErr con "at top level") $+ do disks <- getRamdisk con+ archive <- foldM (unarchiveAndMerge con) Map.empty disks+ xs <- initXenStore+ nics <- listDevices xs+ ns <- newNetworkStack defaultConfig+ devs <- mapM (\ n -> addDevice xs ns n defaultDeviceConfig) nics+ -- make hans go!+ void $ forkIO $ handle (handleErr con "packet processor") $+ processPackets ns+ forM_ devs startDevice+ -- get our addresses and start our web servers+ writeConsole con ("Found " ++ show (length devs) ++ " devices.\n")+ leases <- mapM (\ d -> async $ handle (handleErr con "dhcp client") $+ do writeConsole con ("Starting DHCP client for " ++ show (devMac d) ++ "\n")+ l <- dhcpClient ns (manyRetriesConfig con) d+ writeConsole con ("Picked up DHCP lease for " ++ show (devMac d) ++ "\n")+ return (l, d)) devs+ writeConsole con ("Generated " ++ show (length leases) ++ " leases.\n")+ processAsyncs leases $ \ (mlease, dev) ->+ case mlease of+ Nothing ->+ writeConsole con ("Device " ++ show (devMac dev) +++ " failed to get an address.\n")+ Just lease ->+ do let addr = dhcpAddr lease+ writeConsole con ("Starting listener on " ++ showIP4 addr ""+ ++ " (dev " ++ show (devMac dev) ++ ")\n")+ lsock <- sListen ns defaultSocketConfig addr 80 5+ void $ forkIO $+ handle (handleErr con ("on socket for " ++ showIP4 addr "")) $+ do writeConsole con ("Started on "++showIP4 addr ""++":80\n")+ forever $ do sock <- sAccept (lsock :: TcpListenSocket IP4)+ let r = view tcpRemoteAddr sock+ handleClient con (handleReq con archive r) sock+ writeConsole con ("Known keys:\n")+ writeConsole con ("-----------------------------------------------\n")+ forM_ (Map.keys archive) (\ k -> writeConsole con (show k ++ "\n"))+ writeConsole con ("-----------------------------------------------\n")+ forever (threadDelay (15 * 1000 * 1000))++unarchiveAndMerge :: Console -> Archive -> (String, ByteString) -> IO Archive+unarchiveAndMerge con acc (name, bstr) =+ case unarchive bstr of+ Left err ->+ do writeConsole con (show (S.length bstr) +++ " byte archive failed to expand: "+ ++ err ++ "\n")+ return acc+ Right archive ->+ do writeConsole con (show (S.length bstr) ++ " byte archive " ++ name +++ " unarchived.\n")+ return (archive `Map.union` acc)++processAsyncs :: [Async a] -> (a -> IO ()) -> IO ()+processAsyncs [] _ = return ()+processAsyncs ls process =+ do (asyncx, x) <- waitAny ls+ process x+ processAsyncs (filter (/= asyncx) ls) process++handleErr :: Console -> String -> SomeException -> IO a+handleErr con place e =+ do writeConsole con ("Caught exception " ++ place ++ ": ")+ writeConsole con (show e ++ "\n")+ threadDelay (10 * 1000 * 1000)+ fail "handleErr"++data Result = Result {+ _resCode :: ResponseCode+ , _resKind :: String+ , _resBody :: ByteString+ }++handleReq :: NetworkAddr addr =>+ Console -> Archive ->+ addr -> Request String ->+ IO Result+handleReq con archive fromAddr req =+ go ("site" ++ uriPath (rqURI req)) (2,0,0) $+ go ("site/404.html") (4,0,4) $+ return (Result (4,0,4) "text/html" builtin404)+ where+ go "site/" code otherwiseDo =+ go "site/index.html" code otherwiseDo+ go key code otherwiseDo = putStrLn ("go " ++ key ++ " " ++ show code ++ "\n") >>+ case Map.lookup key archive of+ Just (RegularFileMember rfile) ->+ do let mimeType = mimeByExt defaultMimeMap defaultMimeType (pack key)+ mimeType' = unpack (decodeUtf8 mimeType)+ writeConsole con ("Request for " ++ key ++ " (" ++ mimeType' +++ ") from " ++ showAddr (toAddr fromAddr) "")+ return (Result code mimeType' (regContents rfile))+ Just (LinkMember link) ->+ go (linkTarget link) code otherwiseDo+ Just (SymbolicLinkMember link) ->+ go (linkTarget link) code otherwiseDo+ Nothing ->+ putStrLn ("Nothing found. (" ++ key ++ ")") >> otherwiseDo+ _ ->+ otherwiseDo++builtin404 :: ByteString+builtin404 =+ "<html><head><title>Nope</title></head><body><h1>Page not found!</h1></body>"++getRamdisk :: Console -> IO [(String, ByteString)]+getRamdisk con =+ do start <- domainModuleStart+ case start of+ Left ptr | ptr == nullPtr ->+ do writeConsole con "ERROR: Could not load ramdisk.\n"+ return []+ Left ptr ->+ do len <- domainModuleLength+ res <- unsafePackCStringLen (castPtr ptr, fromIntegral len)+ dflags <- domainFlags+ writeConsole con "Parsing multiboot record.\n"+ if DomainModuleIsMultiboot `elem` dflags+ then return (processMultiboot res)+ else return [("", res)]+ Right _ ->+ do writeConsole con "ERROR: Got PFN from ramdisk; need to fix?\n"+ return []++processMultiboot :: ByteString -> [(String, ByteString)]+processMultiboot bstr =+ case runGet getHeaders bstr of+ Left _ -> []+ Right xs -> xs+ where+ getHeaders =+ do modStart <- fromIntegral `fmap` getWord32host+ modEnd <- fromIntegral `fmap` getWord32host+ cmdLineOff <- fromIntegral `fmap` getWord32host+ _ <- getWord32host+ let cmdLine = C.unpack (S.takeWhile (/= 0) (S.drop cmdLineOff bstr))+ modl = S.take (modEnd - modStart + 1) (S.drop modStart bstr)+ if modStart == 0+ then return []+ else ((cmdLine, modl):) `fmap` getHeaders++handleClient :: Stream s =>+ Console ->+ (Request String -> IO Result) ->+ s ->+ IO ()+handleClient con buildBody s = void (forkIO (run s))+ where+ run :: Stream s => s -> IO ()+ run sock =+ do writeConsole con "Getting request from client.\n"+ mreq <- receiveHTTP sock+ writeConsole con ("Got request from client: " ++ show mreq ++ "\n")+ case mreq of+ Left err -> writeConsole con ("Request error: " ++ show err ++ "\n")+ Right req ->+ do Result rspCode contentType body <- buildBody req+ let len = show (S.length body)+ rspBody = C.unpack body+ keepAlive = [ mkHeader HdrConnection "keep-alive"+ | hdr <- retrieveHeaders HdrConnection req+ , map toLower (hdrValue hdr) == "keep-alive" ]+ conn | null keepAlive = [ mkHeader HdrConnection "Close" ]+ | otherwise = keepAlive+ rspHeaders = mkHeader HdrContentLength len+ : mkHeader HdrContentType contentType+ : conn+ rspReason = toReason rspCode+ resp = Response { .. }+ writeConsole con "Sending response.\n"+ respondHTTP sock resp+ writeConsole con ("Sent response. (" ++ show conn ++ "\n")+ if null keepAlive then close sock else run sock++toReason :: ResponseCode -> String+toReason (2,0,0) = "OK"+toReason (4,0,4) = "Not Found"+toReason (_,_,_) = error "No reason found!"++manyRetriesConfig :: Console -> DhcpConfig+manyRetriesConfig _ = defaultDhcpConfig{ dcRetries = 50000 }
+ src/Network/HTTP/Streams.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE MultiWayIf #-}+module Network.HTTP.Streams(+ )+ where++import Control.Concurrent(threadDelay)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BSC+import Hans.Network(Network)+import Hans.Socket(TcpSocket, sClose, sRead, sCanWrite, sWrite)+import Network.HTTP.Stream(Stream(..), ConnError(..))++instance Network addr => Stream (TcpSocket addr) where+ readLine s = loop ""+ where loop acc =+ do bstr <- sRead s 1+ if | BS.null bstr -> return (Left ErrorClosed)+ | BS.head bstr == 10 -> return (Right (acc ++ "\n"))+ | otherwise -> loop (acc ++ BSC.unpack bstr)+ readBlock s x = loop (fromIntegral x) BS.empty+ where loop 0 acc = return (Right (BSC.unpack acc))+ loop y acc =+ do bstr <- sRead s (fromIntegral y)+ if | BS.length bstr == y -> loop 0 (acc `BS.append` bstr)+ | BS.length bstr == 0 -> return (Left ErrorClosed)+ | otherwise -> loop (y - BS.length bstr)+ (acc `BS.append` bstr)+ writeBlock s str = loop (BSC.pack str)+ where loop x | BS.null x = return (Right ())+ | otherwise =+ do amt <- sWrite s x+ if amt == 0+ then wait x+ else loop (BS.drop (fromIntegral amt) x)+ wait x = do goodToGo <- sCanWrite s+ if goodToGo+ then loop x+ else threadDelay 500000 >> wait x+ close s = sClose s+ closeOnEnd _ _ = return ()+