Commit b30d36d6b9f3c32df48ad09ee85e99169905f451 - unalaq

+12

-21

src/Main.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2	module Main where
3	3
4		import Control.Applicative
5		import Snap.Core
6		import Snap.Util.FileServe
7		import Snap.Http.Server
8		import ~~Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder~~)
	4	import Control.Monad.IO.Class (liftIO)
	5	import Web.Scotty
9	6
10		import Template
	7	import qualified Template
	8	import qualified Storage
11	9
12	10	main :: IO ()
13		main = quickHttpServe site
14
15		site :: Snap ()
16		site =
17		ifTop (writeBuilder $ renderHtmlBuilder $ page $ bigPane) <\|>
18		route [ ("foo", writeBS "bar")
19		, ("echo/:echoparam", echoHandler)
20		] <\|>
21		dir "static" (serveDirectory ".")
22
23		echoHandler :: Snap ()
24		echoHandler = do
25		param <- getParam "echoparam"
26		maybe (writeBS "must specify echo/param in URL")
27		writeBS param
	11	main = scotty 3000 $ do
	12	get "/" $ do
	13	page <- liftIO (Template.paneList `fmap` Storage.getPanes)
	14	html page
	15	get "/chunk/:n" $ do
	16	n <- param "n"
	17	let offset = 0x100000 + (n * 0xff)
	18	html (Template.charList offset n)

+39

-0

src/Storage.hs less more

	1	{-# LANGUAGE DeriveAnyClass #-}
	2	{-# LANGUAGE DeriveGeneric #-}
	3	{-# LANGUAGE OverloadedLists #-}
	4
	5	module Storage where
	6
	7	import Data.Array (Array, array)
	8	import qualified Data.Array as A
	9	import Data.Serialize (Serialize)
	10	import Data.Word (Word8, Word32)
	11	import GHC.Generics (Generic)
	12	import Database.Tansu
	13	import Database.Tansu.Backend.SQLite3
	14
	15	data Character = Character
	16	{ charDescr :: String
	17	, charLang :: String
	18	} deriving (Eq, Show, Generic, Serialize)
	19
	20	newtype Pane = Pane
	21	{ fromPane :: Array Word8 PaneInfo }
	22	deriving (Eq, Show, Generic, Serialize)
	23
	24	data PaneInfo = PaneInfo
	25	{ paneLang :: Maybe String
	26	} deriving (Eq, Show, Generic, Serialize)
	27
	28	data Key = SubpaneIx Word8 \| CodePointIx Word32
	29	deriving (Eq, Show, Generic, Serialize)
	30
	31	getPanes :: IO Pane
	32	getPanes = return $ Pane $ array (minBound, maxBound)
	33	[ (i, PaneInfo (if i == 0
	34	then Just "trinako"
	35	else if i == 1
	36	then Just "verdash"
	37	else Nothing))
	38	\| i <- [minBound..maxBound]
	39	]

+36

-0

src/Style.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Style where
	4
	5	import Control.Monad (void)
	6	import Clay
	7	import Clay.Selector (text)
	8	import Data.Monoid ((<>))
	9	import Data.Text (Text)
	10	import qualified Data.Text.Lazy
	11
	12	groupColors :: [(Text, (Integer, Integer, Integer))] -> Css
	13	groupColors ls = void $ sequence
	14	[ text ("[data-language=\"" <> lang <> "\"]") ? do
	15	background (rgb r g b)
	16	\| (lang, (r, g, b)) <- ls
	17	]
	18
	19	languages =
	20	[ ("trinako", (255, 200, 200))
	21	, ("verdash", (200, 255, 200))
	22	]
	23
	24	style :: Data.Text.Lazy.Text
	25	style = render $ do
	26	body ? do
	27	fontFamily ["Arial", "Helvetica"] [sansSerif]
	28	textAlign (alignSide (sideCenter))
	29	background (rgb 235 235 235)
	30	".main" ? do
	31	width (px 500)
	32	marginLeft auto
	33	marginRight auto
	34	groupColors languages
	35	table ? border solid 1 black
	36	td ? padding (px 5) (px 5) (px 5) (px 5)

+51

-28

src/Template.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2
3		module Template~~(page, bigPane, littlePane)~~ where
	3	module Template where
4	4
5		import Control.Monad (void)
6		import Prelude (String, ($), (++), (==), (.), sequence, show)
7		import qualified Prelude as P
8		import Text.Blaze.Internal (stringValue)
9		import Text.Blaze.Html5
10		import Text.Blaze.Html5.Attributes hiding (title)
	5	import Control.Monad (sequence)
	6	import Data.Array ((!))
	7	import Data.Monoid ((<>))
	8	import Data.Text (Text)
	9	import qualified Data.Text as T
	10	import qualified Data.Text.Lazy as Lazy
	11	import Numeric (showHex)
	12	import Lucid
11	13
12		page :: Html -> Html
13		page contents = docTypeHtml $ do
14		head $ do
15		meta ! charset "utf-8"
16		title ""
17		body $ do
18		div ! class_ "main" $ contents
	14	import Storage
	15	import Style (style)
19	16
20		table' :: [Html] -> Html
21		table' = table . void . sequence
	17	toHex :: (Integral a, Show a) => a -> String
	18	toHex n
	19	\| n < 16 = "0" ++ showHex n ""
	20	\| otherwise = showHex n ""
22	21
23		tr' :: [Html] -> Html
24		tr' = tr . void . sequence
	22	paneList :: Pane -> Lazy.Text
	23	paneList (Pane arr) = page "unalaq" $ do
	24	table_ [class_ "pane"] $ do
	25	sequence
	26	[
	27	tr_ $ sequence
	28	[ td_ lang $
	29	a_ [href_ (T.pack url)] (toHtml pNum)
	30	\| num <- [0x0..0xf],
	31	let lang = case paneLang (arr ! (num + off)) of
	32	Just lang -> [data_ "language" (T.pack lang)]
	33	Nothing -> []
	34	pNum = toHex (num + off)
	35	url = "/chunk/" ++ (show (num + off))
	36	]
	37	\| off <- [0x0,0x10..]
	38	]
	39	return ()
25	40
26		bigPane :: Html
27		bigPane = table' [ tr' [ td ! dataAttribute "x" (stringValue (show x))
28		! dataAttribute "y" (stringValue (show y))
29		$ "[]"
30		\| x <- [0..15]
31		]
32		\| y <- [0..15]
33		]
	41	charList :: Int -> Int -> Lazy.Text
	42	charList offset n = page ("unalaq pane " <> T.pack (toHex n)) $ do
	43	h1_ $ toHtml ("page " <> T.pack (toHex n))
	44	table_ [class_ "chars"] $ do
	45	sequence $ [ tr_ $ do
	46	td_ (toHtml ("U+" ++ toHex (offset + n)))
	47	td_ "TRINAKO LETTER ASH"
	48	\| n <- [0..255]
	49	]
	50	return ()
34	51
35		littlePane :: Html
36		littlePane = P.undefined
	52	page :: Text -> Html () -> Lazy.Text
	53	page title contents = renderText $ html_ $ do
	54	head_ $ do
	55	meta_ [charset_ "utf-8"]
	56	style_ [type_ "text/css"] style
	57	title_ (toHtml title)
	58	body_ $ do
	59	div_ [class_ "main"] contents

+22

-27

unalaq.cabal less more

1		Name: unalaq
2		Version: 0.1
3		Synopsis: Project Synopsis Here
4		Description: Project Description Here
5		License: AllRightsReserved
6		Author: Author
7		Maintainer: maintainer@example.com
8		Stability: Experimental
9		Category: Web
10		Build-type: Simple
11		Cabal-version: >=1.2
	1	name: unalaq
	2	version: 0.1
	3	synopsis: Project Synopsis Here
	4	description: Project Description Here
	5	license: AllRightsReserved
	6	author: Author
	7	maintainer: getty.ritter@gmail.com
	8	stability: Experimental
	9	category: Web
	10	build-type: Simple
	11	cabal-version: >=1.2
12	12
13		Executable unalaq
	13	executable unalaq
14	14	hs-source-dirs: src
15	15	main-is: Main.hs
16	16
17		Build-depends:
18		base >= 4 && < 5,
19		bytestring >= 0.9.1 && < 0.11,
20		MonadCatchIO-transformers >= 0.2.1 && < 0.4,
21		mtl >= 2 && < 3,
22		snap-core >= 0.9 && < 0.10,
23		snap-server >= 0.9 && < 0.10,
24		blaze-html,
25		blaze-markup
26
27		if impl(ghc >= 6.12.0)
28		ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
29		-fno-warn-unused-do-bind
30		else
31		~~ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2~~
	17	build-depends: base,
	18	array,
	19	cereal,
	20	scotty,
	21	clay,
	22	lucid,
	23	tansu,
	24	tansu-sqlite3,
	25	text,
	26	transformers