summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-07-25 21:26:13 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-07-25 21:26:13 -0400
commit32d3cffc4cf075d7c20fee8addc556f402e94cd2 (patch)
tree4640fa6618d6c14b652dada4d0423e56ea3a3f95
parent03979d4d54e7b0ce76fa296e57b9b5e1820ce7b1 (diff)
run yesod, and launch webapp on startup
-rw-r--r--Assistant.hs8
-rw-r--r--Assistant/Threads/WebApp.hs43
-rw-r--r--Makefile20
-rw-r--r--Utility/WebApp.hs104
-rw-r--r--debian/control1
-rw-r--r--doc/design/assistant/webapp.mdwn2
-rw-r--r--doc/git-annex.mdwn6
-rw-r--r--doc/install.mdwn2
-rw-r--r--git-annex.cabal13
9 files changed, 189 insertions, 10 deletions
diff --git a/Assistant.hs b/Assistant.hs
index 0049d3177..de996aa74 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -88,6 +88,8 @@
- are indicated by writing to this TMVar.
-}
+{-# LANGUAGE CPP #-}
+
module Assistant where
import Assistant.Common
@@ -108,6 +110,9 @@ import Assistant.Threads.Transferrer
import Assistant.Threads.SanityChecker
import Assistant.Threads.MountWatcher
import Assistant.Threads.TransferScanner
+#ifdef WITH_WEBAPP
+import Assistant.Threads.WebApp
+#endif
import qualified Utility.Daemon
import Utility.LogFile
import Utility.ThreadScheduler
@@ -146,6 +151,9 @@ startDaemon assistant foreground
, sanityCheckerThread st dstatus transferqueue changechan
, mountWatcherThread st dstatus scanremotes
, transferScannerThread st scanremotes transferqueue
+#ifdef WITH_WEBAPP
+ , webAppThread dstatus
+#endif
, watchThread st dstatus transferqueue changechan
]
debug "assistant"
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
new file mode 100644
index 000000000..1d9d3cc2f
--- /dev/null
+++ b/Assistant/Threads/WebApp.hs
@@ -0,0 +1,43 @@
+{- git-annex assistant webapp
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.Threads.WebApp where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Utility.WebApp
+
+import Yesod
+
+data WebApp = WebApp DaemonStatusHandle
+
+mkYesod "WebApp" [parseRoutes|
+/ HomeR GET
+/config ConfigR GET
+|]
+
+instance Yesod WebApp
+
+getHomeR :: Handler RepHtml
+getHomeR = defaultLayout [whamlet|Hello, World<p><a href=@{ConfigR}>config|]
+
+getConfigR :: Handler RepHtml
+getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|]
+
+webAppThread :: DaemonStatusHandle -> IO ()
+webAppThread dstatus = do
+ app <- toWaiApp (WebApp dstatus)
+ app' <- ifM debugEnabled
+ ( return $ httpDebugLogger app
+ , return app
+ )
+ runWebApp app' browser
+ where
+ browser p = void $
+ runBrowser $ "http://" ++ localhost ++ ":" ++ show p
diff --git a/Makefile b/Makefile
index 8b9b35bdd..9f312dc49 100644
--- a/Makefile
+++ b/Makefile
@@ -1,19 +1,23 @@
+CFLAGS=-Wall
+IGNORE=-ignore-package monads-fd -ignore-package monads-tf
+BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility
+FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP
+
bins=git-annex
mans=git-annex.1 git-annex-shell.1
sources=Build/SysConfig.hs Utility/Touch.hs Utility/Mounts.hs
all=$(bins) $(mans) docs
-CFLAGS=-Wall
-
OS:=$(shell uname | sed 's/[-_].*//')
ifeq ($(OS),Linux)
-BASEFLAGS_OPTS=-DWITH_INOTIFY -DWITH_DBUS
+OPTFLAGS=-DWITH_INOTIFY -DWITH_DBUS
clibs=Utility/libdiskfree.o Utility/libmounts.o
else
# BSD system
-BASEFLAGS_OPTS=-DWITH_KQUEUE
+OPTFLAGS=-DWITH_KQUEUE
clibs=Utility/libdiskfree.o Utility/libmounts.o Utility/libkqueue.o
ifeq ($(OS),Darwin)
+OPTFLAGS=-DWITH_KQUEUE -DOSX
# Ensure OSX compiler builds for 32 bit when using 32 bit ghc
GHCARCH:=$(shell ghc -e 'print System.Info.arch')
ifeq ($(GHCARCH),i386)
@@ -23,12 +27,10 @@ endif
endif
PREFIX=/usr
-IGNORE=-ignore-package monads-fd -ignore-package monads-tf
-BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS)
-GHCFLAGS=-O2 $(BASEFLAGS)
+GHCFLAGS=-O2 $(BASEFLAGS) $(FEATURES)
ifdef PROFILE
-GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS)
+GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) $(FEATURES) $(OPTFLAGS)
endif
GHCMAKE=ghc $(GHCFLAGS) --make
@@ -43,7 +45,7 @@ all: $(all)
sources: $(sources)
# Disables optimisation. Not for production use.
-fast: GHCFLAGS=$(BASEFLAGS)
+fast: GHCFLAGS=$(BASEFLAGS) $(FEATURES) $(OPTFLAGS)
fast: $(bins)
Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
new file mode 100644
index 000000000..614a57cea
--- /dev/null
+++ b/Utility/WebApp.hs
@@ -0,0 +1,104 @@
+{- WAI webapp
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings, CPP #-}
+
+module Utility.WebApp where
+
+import Common
+
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Logger
+import Control.Monad.IO.Class
+import Network.HTTP.Types
+import System.Log.Logger
+import Data.ByteString.Lazy.UTF8
+import Data.ByteString.Lazy
+import Data.CaseInsensitive as CI
+import Network.Socket
+import Control.Exception
+
+localhost :: String
+localhost = "localhost"
+
+{- Runs a web browser on a given url.
+ -
+ - Note: The url *will* be visible to an attacker. -}
+runBrowser :: String -> IO Bool
+runBrowser url = boolSystem cmd [Param url]
+ where
+#if MAC
+ cmd = "open"
+#else
+ cmd = "xdg-open"
+#endif
+
+{- Binds to a socket on localhost, and runs a webapp on it.
+ -
+ - An IO action can also be run, to do something with the port number,
+ - such as start a web browser to view the webapp.
+ -}
+runWebApp :: Application -> (PortNumber -> IO ()) -> IO ()
+runWebApp app observer = do
+ sock <- localSocket
+ observer =<< socketPort sock
+ runSettingsSocket defaultSettings sock app
+
+{- Binds to a local socket, selecting any free port.
+ -
+ - As a (very weak) form of security, only connections from
+ - localhost are accepted. -}
+localSocket :: IO Socket
+localSocket = do
+ addrs <- getAddrInfo (Just hints) (Just localhost) Nothing
+ go $ Prelude.head addrs
+ where
+ hints = defaultHints
+ { addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]
+ , addrSocketType = Stream
+ }
+ go addr = bracketOnError (open addr) close (use addr)
+ open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ close = sClose
+ use addr sock = do
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock (addrAddress addr)
+ listen sock maxListenQueue
+ return sock
+
+{- Checks if debugging is actually enabled. -}
+debugEnabled :: IO Bool
+debugEnabled = do
+ l <- getRootLogger
+ return $ getLevel l <= Just DEBUG
+
+{- WAI middleware that logs using System.Log.Logger at debug level.
+ -
+ - Recommend only inserting this middleware when debugging is actually
+ - enabled, as it's not optimised at all.
+ -}
+httpDebugLogger :: Middleware
+httpDebugLogger waiApp req = do
+ logRequest req
+ waiApp req
+
+logRequest :: MonadIO m => Request -> m ()
+logRequest req = do
+ liftIO $ debugM "WebApp" $ unwords
+ [ showSockAddr $ remoteHost req
+ , frombs $ requestMethod req
+ , frombs $ rawPathInfo req
+ --, show $ httpVersion req
+ --, frombs $ lookupRequestField "referer" req
+ , frombs $ lookupRequestField "user-agent" req
+ ]
+ where
+ frombs v = toString $ fromChunks [v]
+
+lookupRequestField :: CI Ascii -> Request -> Ascii
+lookupRequestField k req = fromMaybe "" . lookup k $ requestHeaders req
diff --git a/debian/control b/debian/control
index 35cbfde05..c7531cd3f 100644
--- a/debian/control
+++ b/debian/control
@@ -23,6 +23,7 @@ Build-Depends:
libghc-hinotify-dev [linux-any],
libghc-stm-dev (>= 2.3),
libghc-dbus-dev,
+ libghc-yesod-dev,
ikiwiki,
perlmagick,
git,
diff --git a/doc/design/assistant/webapp.mdwn b/doc/design/assistant/webapp.mdwn
index 598c1ff3a..cec766c57 100644
--- a/doc/design/assistant/webapp.mdwn
+++ b/doc/design/assistant/webapp.mdwn
@@ -2,7 +2,7 @@ The webapp is a web server that displays a shiny interface.
## security
-* Listen only to localhost.
+* Listen only to localhost. **done**
* Instruct the user's web browser to open an url that contains a secret
token. This guards against other users on the same system.
* I would like to avoid passwords or other authentication methods,
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 85a5a18f0..282b1fda5 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -188,6 +188,12 @@ subdirectories).
* assistant
Like watch, but also automatically syncs changes to other remotes.
+ Typically started at boot, or when you log in.
+
+* webapp
+
+ Opens a web browser, viewing the git-annex assistant's web app.
+ (If the assistant is not already running, it will be automatically started.)
# REPOSITORY SETUP COMMANDS
diff --git a/doc/install.mdwn b/doc/install.mdwn
index 54d6ecb6b..058c3cf6e 100644
--- a/doc/install.mdwn
+++ b/doc/install.mdwn
@@ -48,6 +48,8 @@ To build and use git-annex, you will need:
(optional; Linux only)
* [dbus](http://hackage.haskell.org/package/dbus)
(optional)
+ * [yesod](http://hackage.haskell.org/package/yesod)
+ (optional; for webapp)
* Shell commands
* [git](http://git-scm.com/)
* [uuid](http://www.ossp.org/pkg/lib/uuid/)
diff --git a/git-annex.cabal b/git-annex.cabal
index 2e312d4c3..11412d19a 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -37,6 +37,9 @@ Flag Dbus
Flag Assistant
Description: Enable git-annex assistant and watch command
+Flag Webapp
+ Description: Enable git-annex webapp
+
Executable git-annex
Main-Is: git-annex.hs
Build-Depends: MissingH, hslogger, directory, filepath,
@@ -61,11 +64,21 @@ Executable git-annex
if os(linux) && flag(Inotify)
Build-Depends: hinotify
CPP-Options: -DWITH_INOTIFY
+ else
+ if (! os(windows))
+ CPP-Options: -DWITH_KQUEUE
if flag(Dbus)
Build-Depends: dbus
CPP-Options: -DWITH_DBUS
+ if flag(Webapp)
+ Build-Depends: yesod
+ CPP-Options: -DWITH_WEBAPP
+
+ if (os(darwin))
+ CPP-Options: -DOSX
+
Test-Suite test
Type: exitcode-stdio-1.0
Main-Is: test.hs