From c99d184584e014aff4953fa8f90c9b3b6dc65229 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Thu, 26 Dec 2013 15:25:03 -0500 Subject: [PATCH] Commit persistent stuff. --- htsn-rdbms-import.cabal | 6 ++- src/Main.hs | 54 ++++++++++++++++++++++----- src/TSN/Injuries.hs | 83 ++++++++++++++++++++++++----------------- 3 files changed, 98 insertions(+), 45 deletions(-) diff --git a/htsn-rdbms-import.cabal b/htsn-rdbms-import.cabal index f95a7a6..0167c84 100644 --- a/htsn-rdbms-import.cabal +++ b/htsn-rdbms-import.cabal @@ -15,11 +15,15 @@ description: executable htsn-rdbms-import build-depends: base == 4.*, + cmdargs >= 0.10.6, + configurator == 0.2.*, hxt == 9.3.*, persistent == 1.2.*, + persistent-postgresql == 1.2.*, + persistent-sqlite == 1.2.*, persistent-template == 1.2.*, pretty-show == 1.*, - regular == 0.3.* + transformers == 0.3.* main-is: Main.hs diff --git a/src/Main.hs b/src/Main.hs index d2e5172..950a2a1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,18 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + module Main where +import Control.Monad.IO.Class (liftIO) +import Data.Maybe ( listToMaybe ) +import Database.Persist ( insert ) +import Database.Persist.Sql ( runMigration ) +import Database.Persist.Sqlite ( runSqlite ) import Text.Show.Pretty ( ppShow ) -import Text.XML.HXT.Core +import Text.XML.HXT.Core ( + SysConfigList, + XmlPickler, + no, + runX, + withPreserveComment, + withRemoveWS, + withValidate, + xpickle, + xunpickleDocument, + yes ) + +import TSN.Injuries ( InjuriesMessage, migrate_injuries ) + + +parse_opts :: SysConfigList +parse_opts = + [ withPreserveComment no, + withRemoveWS yes, + withValidate no ] -import qualified TSN.Injuries as Injuries +parse_file :: XmlPickler a => FilePath -> IO (Maybe a) +parse_file path = + fmap listToMaybe $ + runX ( xunpickleDocument xpickle parse_opts path ) +main_sql :: IO () +main_sql = + runSqlite "foo.sqlite3" $ do + runMigration migrate_injuries + msg :: Maybe InjuriesMessage <- liftIO $ parse_file + "test/xml/injuriesxml.xml" + case msg of + Nothing -> return () + Just m -> do + msg_id <- insert m + return () main :: IO () main = do - res <- runX ( xunpickleDocument Injuries.pickle_message - [ withValidate no - , withTrace 1 - , withRemoveWS yes - , withPreserveComment no - ] "test/xml/injuriesxml.xml" ) - putStr $ ppShow res + msg :: Maybe InjuriesMessage <- parse_file "test/xml/injuriesxml.xml" + putStr $ ppShow msg diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs index 7425ab5..956aa9d 100644 --- a/src/TSN/Injuries.hs +++ b/src/TSN/Injuries.hs @@ -2,75 +2,88 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} module TSN.Injuries where -import Generics.Regular -import Database.Persist.TH -import Text.XML.HXT.Core +import Database.Persist.TH ( + mkDeleteCascade, + mkMigrate, + mkPersist, + persistLowerCase, + share, + sqlOnlySettings ) +import Text.XML.HXT.Core ( + PU, + XmlPickler(..), + xp4Tuple, + xp6Tuple, + xpElem, + xpList, + xpPrim, + xpText, + xpWrap ) -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -Listing +import Uncurry (uncurry4, uncurry5, uncurry6) + +share [mkPersist sqlOnlySettings, + mkDeleteCascade sqlOnlySettings, + mkMigrate "migrate_injuries"] [persistLowerCase| +InjuriesListing team String teamno Int injuries String updated Bool deriving Show -Message +InjuriesMessage xml_file_id Int heading String category String sport String - listings [Listing] + listings [InjuriesListing] time_stamp String deriving Show |] -pickle_listing :: PU Listing -pickle_listing = + +pickle_injurieslisting :: PU InjuriesListing +pickle_injurieslisting = xpElem "listing" $ - xpWrap (\(w,x,y,z) -> Listing w x y z, - \l -> (listingTeam l, - listingTeamno l, - listingInjuries l, - listingUpdated l)) $ + xpWrap (uncurry4 InjuriesListing, + \l -> (injuriesListingTeam l, + injuriesListingTeamno l, + injuriesListingInjuries l, + injuriesListingUpdated l)) $ xp4Tuple (xpElem "team" xpText) (xpElem "teamno" xpPrim) (xpElem "injuries" xpText) (xpElem "updated" xpPrim) -instance XmlPickler Listing where - xpickle = pickle_listing +instance XmlPickler InjuriesListing where + xpickle = pickle_injurieslisting -$(deriveAll ''Listing "PFListing") -type instance PF Listing = PFListing - -pickle_message :: PU Message -pickle_message = +pickle_injuriesmessage :: PU InjuriesMessage +pickle_injuriesmessage = xpElem "message" $ - xpWrap (\(u,v,w,x,y,z) -> Message u v w x y z, - \m -> (messageXml_file_id m, - messageHeading m, - messageCategory m, - messageSport m, - messageListings m, - messageTime_stamp m)) $ + xpWrap (uncurry6 InjuriesMessage, + \m -> (injuriesMessageXml_file_id m, + injuriesMessageHeading m, + injuriesMessageCategory m, + injuriesMessageSport m, + injuriesMessageListings m, + injuriesMessageTime_stamp m)) $ xp6Tuple (xpElem "XML_File_ID" xpPrim) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) - (xpList pickle_listing) + (xpList pickle_injurieslisting) (xpElem "time_stamp" xpText) -instance XmlPickler Message where - xpickle = pickle_message - -$(deriveAll ''Message "PFMessage") -type instance PF Message = PFMessage +instance XmlPickler InjuriesMessage where + xpickle = pickle_injuriesmessage -- 2.43.2