Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

initialize yesodcrud

  • Loading branch information...
commit 681f2ac15a3e1fdeab323a8227e4657feb25a78e 0 parents
@wavewave authored
25 LICENSE
@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2011, Ian-Woo Kim. 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.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.
10 Setup.lhs
@@ -0,0 +1,10 @@
+#! /usr/bin/env runhaskell
+
+> import Distribution.Simple
+> import Distribution.PackageDescription
+> --import System.Process
+> main = defaultMain
+> --main = defaultMainWithHooks testUserHooks
+> --testUserHooks = simpleUserHooks {
+> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo
+> -- }
92 lib/Application/YesodCRUD/Type.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE DeriveDataTypeable,
+ TemplateHaskell,
+ TypeFamilies,
+ TypeSynonymInstances,
+ OverloadedStrings #-}
+
+module Application.YesodCRUD.Type where
+
+import Control.Applicative
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Typeable
+import Data.Data
+import Data.SafeCopy
+import qualified Data.Map as M
+
+import Data.Acid
+import Data.UUID
+import Data.Aeson
+import Data.Text.Encoding as E
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString as B
+
+data YesodcrudInfo = YesodcrudInfo {
+ yesodcrud_uuid :: UUID,
+ yesodcrud_name :: String
+} deriving (Show,Typeable,Data)
+
+
+instance FromJSON UUID where
+ parseJSON x = do r <- return . fromString . C.unpack . E.encodeUtf8 =<< parseJSON x
+ case r of
+ Nothing -> fail ("UUID parsing failed " ++ show x )
+ Just uuid -> return uuid
+
+instance ToJSON UUID where
+ toJSON = toJSON . E.decodeUtf8 . C.pack . toString
+
+instance FromJSON YesodcrudInfo where
+ parseJSON (Object v) = YesodcrudInfo <$> v .: "uuid" <*> v .: "name"
+
+instance ToJSON YesodcrudInfo where
+ toJSON (YesodcrudInfo uuid name) = object [ "uuid" .= uuid , "name" .= name ]
+
+
+instance SafeCopy UUID where
+ putCopy uuid = contain $ safePut (toByteString uuid)
+ getCopy = contain
+ $ maybe (fail "cannot parse UUID") return . fromByteString
+ =<< safeGet
+
+$(deriveSafeCopy 0 'base ''YesodcrudInfo)
+
+type YesodcrudInfoRepository = M.Map UUID YesodcrudInfo
+
+addYesodcrud :: YesodcrudInfo -> Update YesodcrudInfoRepository YesodcrudInfo
+addYesodcrud minfo = do
+ m <- get
+ let (r,m') = M.insertLookupWithKey (\_k _o n -> n) (yesodcrud_uuid minfo) minfo m
+ put m'
+ return minfo
+
+queryYesodcrud :: UUID -> Query YesodcrudInfoRepository (Maybe YesodcrudInfo)
+queryYesodcrud uuid = do
+ m <- ask
+ return (M.lookup uuid m)
+
+queryAll :: Query YesodcrudInfoRepository [YesodcrudInfo]
+queryAll = do m <- ask
+ return (M.elems m)
+
+
+updateYesodcrud :: YesodcrudInfo -> Update YesodcrudInfoRepository (Maybe YesodcrudInfo)
+updateYesodcrud minfo = do
+ m <- get
+ let (r,m') = M.updateLookupWithKey (\_ _ -> Just minfo) (yesodcrud_uuid minfo) m
+ put m'
+ maybe (return Nothing) (const (return (Just minfo))) r
+
+deleteYesodcrud :: UUID -> Update YesodcrudInfoRepository (Maybe YesodcrudInfo)
+deleteYesodcrud uuid = do
+ m <- get
+ let r = M.lookup uuid m
+ case r of
+ Just _ -> do
+ let m' = M.delete uuid m
+ put m'
+ return r
+ Nothing -> return Nothing
+
+
+$(makeAcidic ''YesodcrudInfoRepository [ 'addYesodcrud, 'queryYesodcrud, 'queryAll, 'updateYesodcrud, 'deleteYesodcrud] )
27 yesodcrud-type.cabal
@@ -0,0 +1,27 @@
+Name: yesodcrud-type
+Version: 0.0
+Synopsis: CRUD sample type
+Description: CRUD sample type
+License: BSD3
+License-file: LICENSE
+Author: Ian-Woo Kim
+Maintainer: Ian-Woo Kim <ianwookim@gmail.com>
+Build-Type: Simple
+Cabal-Version: >= 1.8
+data-files:
+
+Library
+ hs-source-dirs: lib
+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind
+ ghc-prof-options: -caf-all -auto-all
+ Build-Depends:
+ base == 4.*,
+ mtl == 2.*,
+ uuid == 1.2.*,
+ containers == 0.4.*,
+ safecopy == 0.6.*,
+ acid-state == 0.6.*,
+ bytestring == 0.9.*,
+ text == 0.11.*,
+ aeson==0.4.*
+ exposed-modules: Application.YesodCRUD.Type
Please sign in to comment.
Something went wrong with that request. Please try again.