First files of v2

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2013, David Baumgartner
+
+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 David Baumgartner 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.

Limonad.cabal

@@ -0,0 +1,18 @@
+name:                Limonad
+version:             1.2.0.1
+synopsis:            limonad is a web interface for Darcs DCVS
+-- description:         
+homepage:            http://geekschmerzen.org/limonad/
+license:             BSD3
+license-file:        LICENSE
+author:              David Baumgartner
+maintainer:          [email protected]
+-- copyright:           
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.8
+
+executable limonad
+  main-is: Main             
+  -- other-modules:       
+  build-depends:       base ==4.5.*, MissingH ==1.2.*, parsec ==3.1.*, mime==0.3.*

Limonad/Interface/Types.hs

@@ -0,0 +1,215 @@
+module Limonad.Interface.Types where
+
+	import qualified Data.ByteString as B
+	import qualified Data.Time as Time
+	import qualified Codec.MIME.Type as MIME
+	import qualified Limonad.Templates.Shortcuts as Tpl
+	import Data.Functor
+	import Limonad.Utils
+	import Limonad.Types
+
+	data Content = Content (IO B.ByteString)
+
+	data View = View {
+			getStatusCode :: HttpStatus,
+			getMimeType :: MIME.Type,
+			getDate :: Maybe Time.UTCTime,
+			getExpire :: Maybe Time.UTCTime,
+			getContent :: Content
+		}
+
+	data Request = Request {
+			getMethod :: Maybe String,
+			getParams :: [(String, String)],
+			getRefer :: Maybe String,
+			getHost :: Maybe String
+		}
+
+	data Route = Route {
+			getPath :: String,
+			getAllowedMethod :: [String]
+		}
+
+	type Routes = [Route]
+
+	class Status a where
+		code :: a -> Int 
+		string :: a -> String 
+
+	data HttpStatus = Continue
+					| SwitchingProtocols
+					| Ok
+					| Created
+					| Accepted
+					| NonAuthoritativeInformation
+					| NoContent
+					| ResetContent
+					| PartialContent
+					| MultipleChoices
+					| MovedPermanently
+					| Found
+					| SeeOther
+					| NotModified
+					| UseProxy
+					| TemporaryRedirect
+					| BadRequest
+					| Unauthorized
+					| PaymentRequired
+					| Forbidden
+					| NotFound
+					| MethodNotAllowed
+					| NotAcceptable
+					| ProxyAuthenticationRequired
+					| RequestTimeout
+					| Conflict
+					| Gone
+					| LengthRequired
+					| PreconditionFailed
+					| RequestEntityTooLarge
+					| RequestURITooLong
+					| UnsupportedMediaType
+					| RequestedRangeNotSatisfiable
+					| ExpectationFailed
+					| IMATeapot
+					| InternalServerError
+					| NotImplemented
+					| BadGateway
+					| ServiceUnavailable
+					| GatewayTimeout
+					| HTTPVersionNotSupported
+
+	instance Status HttpStatus where
+		code Continue = 100
+		code SwitchingProtocols = 101
+		code Ok = 200
+		code Created = 201
+		code Accepted = 202
+		code NonAuthoritativeInformation = 203
+		code NoContent = 204
+		code ResetContent = 205
+		code PartialContent = 206
+		code MultipleChoices = 300
+		code MovedPermanently = 301
+		code Found = 302
+		code SeeOther = 303
+		code NotModified = 304
+		code UseProxy = 305
+		code TemporaryRedirect = 307
+		code BadRequest = 400
+		code Unauthorized = 401
+		code PaymentRequired = 402
+		code Forbidden = 403
+		code NotFound = 404
+		code MethodNotAllowed = 405
+		code NotAcceptable = 406
+		code ProxyAuthenticationRequired = 407
+		code RequestTimeout = 408
+		code Conflict = 409
+		code Gone = 410
+		code LengthRequired = 411
+		code PreconditionFailed = 412
+		code RequestEntityTooLarge = 413
+		code RequestURITooLong = 414
+		code UnsupportedMediaType = 415
+		code RequestedRangeNotSatisfiable = 416
+		code ExpectationFailed = 417
+		code IMATeapot = 418
+		code InternalServerError = 500
+		code NotImplemented = 501
+		code BadGateway = 502
+		code ServiceUnavailable = 503
+		code GatewayTimeout = 504
+		code HTTPVersionNotSupported = 505
+		string Continue = "Continue"
+		string SwitchingProtocols = "Switching Protocols"
+		string Ok = "OK"
+		string Created = "Created"
+		string Accepted = "Accepted"
+		string NonAuthoritativeInformation = "Non-Authoritative Information"
+		string NoContent = "No Content"
+		string ResetContent = "Reset Content"
+		string PartialContent = "Partial Content"
+		string MultipleChoices = "Multiple Choices"
+		string MovedPermanently = "Moved Permanently"
+		string Found = "Found"
+		string SeeOther = "See Other"
+		string NotModified = "Not Modified"
+		string UseProxy = "Use Proxy"
+		string TemporaryRedirect = "Temporary Redirect"
+		string BadRequest = "Bad Request"
+		string Unauthorized = "Unauthorized"
+		string PaymentRequired = "Payment Required"
+		string Forbidden = "Forbidden"
+		string NotFound = "Not Found"
+		string MethodNotAllowed = "Method Not Allowed"
+		string NotAcceptable = "Not Acceptable"
+		string ProxyAuthenticationRequired = "Proxy Authentication Required"
+		string RequestTimeout = "Request Timeout"
+		string Conflict = "Conflict"
+		string Gone = "Gone"
+		string LengthRequired = "Length Required"
+		string PreconditionFailed = "Precondition Failed"
+		string RequestEntityTooLarge = "Request Entity Too Large"
+		string ExpectationFailed = "Expectation Failed"
+		string IMATeapot = "I'm a teapot"
+		string InternalServerError = "Internal Server Error"
+		string NotImplemented = "Not Implemented"
+		string BadGateway = "Bad Gateway"
+		string ServiceUnavailable = "Service Unavailable"
+		string GatewayTimeout = "Gateway Timeout"
+		string HTTPVersionNotSupported = "HTTP Version Not Supported"
+
+	instance Show HttpStatus where
+		show a = show $ code a ++ string a
+
+	text :: IO String -> View
+	text c = View {
+			getMimeType = MIME.nullType,
+			getDate = Nothing,
+			getExpire = Nothing,
+			getContent = Content (s2bs <$> c)
+		}
+
+	html :: IO B.ByteString -> View
+	html c = View {
+			getMimeType = MIME.Type { mimeType = MIME.Application "xhtml+xml", mimeParams = [] },
+			getDate = Nothing,
+			getExpire = Nothing,
+			getContent = Content $ c
+		}
+
+	tpl :: FilePath -> Env -> View
+	tpl f e = View {
+			getMimeType = MIME.Type { mimeType = MIME.Application "xhtml+xml", mimeParams = [] },
+			getDate = Nothing,
+			getExpire = Nothing,
+			getContent = Content (s2bs <$> Tpl.renderFile f e)
+		}
+
+	css :: IO B.ByteString -> View
+	css c = View {
+			getMimeType = MIME.Type { mimeType = MIME.Text "css", mimeParams = [] },
+			getDate = Nothing,
+			getExpire = Nothing,
+			getContent = Content $ c
+		}
+
+	js :: IO B.ByteString -> View
+	js c = View {
+			getMimeType = MIME.Type { mimeType = MIME.Text "javascript", mimeParams = [] },
+			getDate = Nothing,
+			getExpire = Nothing,
+			getContent = Content $ c
+		}
+
+	mkEnv :: Request -> Env
+	mkEnv r = Env [Static a b |(a, b) <- getParams r]
+
+	defaultRoute :: String -> Route 
+	defaultRoute p = Route { getPath = p }
+
+	(/+) :: Routes -> String -> Routes
+	(/+) r n = r /: (defaultRoute n)
+
+	(/:) :: Routes -> Route -> Routes
+	(/:) r n = n:r

Limonad/Languages/Html.hs

@@ -0,0 +1,3 @@
+module Limonad.Languages.Html where
+
+

Limonad/Markdown/Parser.hs

@@ -0,0 +1,64 @@
+module Limonad.Markdown.Parser where
+
+	import Limonad.Markdown.Types
+	import Text.ParserCombinators.Parsec
+	import Control.Applicative hiding (many, (<|>))
+	import Data.Functor
+
+	dnl = newline >> newline
+
+	parseMarkdown :: String -> [Markdown]
+	parseMarkdown input = case parse parseAll "markdown error" input of
+		Right template -> template
+		Left err -> error $ show err
+
+	parseAll :: Parser [Markdown]
+	parseAll = many (try parseHeaders <|> try parseQuote <|> try parseStrongEmphasis <|> parseEmphasis)
+
+	parseHeaders :: Parser Markdown
+	parseHeaders = try (mkParserHeader 1 Header1) <|> try (mkParserHeader 2 Header2) <|> try (mkParserHeader 3 Header3) <|> try (mkParserHeader 4 Header4) <|> try (mkParserHeader 5 Header5) <|> try (mkParserHeader 6 Header6) <|> try parseHeader1F <|> parseHeader2F
+
+	parseHeader1F :: Parser Markdown
+	parseHeader1F = do
+		title <- many1 alphaNum
+		many (char '=')
+		return $ Header1 title
+
+	parseHeader2F :: Parser Markdown
+	parseHeader2F = do
+		title <- many1 alphaNum
+		many (char '-')
+		return $ Header1 title
+
+	mkParserHeader :: Int -> (String -> Markdown) -> Parser Markdown
+	mkParserHeader cnt t = do
+		string (take cnt $ repeat '#')
+		spaces 
+		title <- many1 alphaNum
+		try $ string (take cnt $ repeat '#')
+		return $ t title
+
+	parseQuote :: Parser Markdown
+	parseQuote = do
+		c <- manyTill (char '>' <* anyChar) dnl
+		case (parse parseAll "markdown error" $ concat $ map (drop 1) $ lines c) of 
+			Right a -> return $ Quote a
+			Left e -> error $ show e
+
+	parseParagraph :: Parser Markdown
+	parseParagraph = do
+		c <- manyTill anyToken dnl
+		case (parse parseAll "markdown error" c) of 
+			Right a -> return $ Paragraph a
+			Left e -> error $ show e
+
+	parseEmphasis :: Parser Markdown
+	parseEmphasis = do
+		t <- try (between (char '*') (char '*') anyChar) <|> (between (char '_') (char '_') anyChar)
+		return $ Emphasis [t]
+
+	parseStrongEmphasis :: Parser Markdown
+	parseStrongEmphasis = do
+		t <- try (between (string "**") (string "**") anyChar) <|> (between (string "__") (string "__") anyChar)
+		return $ StrongEmphasis [t]
+

Limonad/Markdown/Types.hs

@@ -0,0 +1,24 @@
+module Limonad.Markdown.Types where
+
+	data Markdown = Header1 String
+				  | Header2 String
+				  | Header3 String
+				  | Header4 String
+				  | Header5 String
+				  | Header6 String
+				  | Paragraph [Markdown] --
+				  | Quote [Markdown]
+				  | Emphasis String
+				  | StrongEmphasis String
+				  | List [Markdown]
+				  | OrderedList [Markdown]
+				  | Link String (Maybe String) [Markdown]
+				  | ReferenceCall String String
+				  | ReferenceDef String String
+				  | InlineReference String String
+				  | Image String (Maybe String) String
+				  | ImageCall String String
+				  | ImageRef String String (Maybe String)
+				  | Code (Maybe String) [String]
+				  | InlineClode String
+				  deriving (Eq, Ord, Show)

Limonad/Server/Run.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Limonad.Server.Run (run) where
+
+	import Limonad.Server.Types
+	import Limonad.Utils
+	import qualified Data.ByteString as B
+	import Network hiding (accept)
+	import Network.Socket
+	import Network.Socket.ByteString (sendAll)
+	import Control.Concurrent
+
+	send :: View -> IO ()
+
+	handle :: Socket -> IO ()
+	handle sock = do
+		sendAll	
+
+	loop sock = accept sock >>= 
+					\(conn, addr) -> 
+						forkIO $ handle sock >> loop sock
+
+	run :: Config -> IO ()
+	run config = 
+		withSocketsDo (listenOn $ getPort config >>= loop)